3 * Copyright (c) 1987-1999 Larry Wall
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
11 * "A ship then new they built for him/of mithril and of elven glass" --Bilbo
15 #define PERL_IN_PERL_C
17 #include "patchlevel.h" /* for local_patches */
19 /* XXX If this causes problems, set i_unistd=undef in the hint file. */
24 #if !defined(STANDARD_C) && !defined(HAS_GETENV_PROTOTYPE)
25 char *getenv (char *); /* Usually in <stdlib.h> */
28 static I32 read_e_script(pTHXo_ int idx, SV *buf_sv, int maxlen);
43 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
51 perl_alloc(struct IPerlMem* ipM, struct IPerlEnv* ipE,
52 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
53 struct IPerlDir* ipD, struct IPerlSock* ipS,
54 struct IPerlProc* ipP)
56 CPerlObj* pPerl = new(ipM) CPerlObj(ipM, ipE, ipStd, ipLIO, ipD, ipS, ipP);
64 #ifdef PERL_IMPLICIT_SYS
66 perl_alloc_using(struct IPerlMem* ipM, struct IPerlEnv* ipE,
67 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
68 struct IPerlDir* ipD, struct IPerlSock* ipS,
69 struct IPerlProc* ipP)
71 PerlInterpreter *my_perl;
73 /* New() needs interpreter, so call malloc() instead */
74 my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
75 PERL_SET_INTERP(my_perl);
76 Zero(my_perl, 1, PerlInterpreter);
90 PerlInterpreter *my_perl;
92 /* New() needs interpreter, so call malloc() instead */
93 my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
94 PERL_SET_INTERP(my_perl);
97 #endif /* PERL_IMPLICIT_SYS */
98 #endif /* PERL_OBJECT */
101 perl_construct(pTHXx)
106 struct perl_thread *thr = NULL;
107 #endif /* FAKE_THREADS */
108 #endif /* USE_THREADS */
112 PL_perl_destruct_level = 1;
114 if (PL_perl_destruct_level > 0)
118 /* Init the real globals (and main thread)? */
123 #ifdef ALLOC_THREAD_KEY
126 if (pthread_key_create(&PL_thr_key, 0))
127 Perl_croak(aTHX_ "panic: pthread_key_create");
129 MUTEX_INIT(&PL_sv_mutex);
131 * Safe to use basic SV functions from now on (though
132 * not things like mortals or tainting yet).
134 MUTEX_INIT(&PL_eval_mutex);
135 COND_INIT(&PL_eval_cond);
136 MUTEX_INIT(&PL_threads_mutex);
137 COND_INIT(&PL_nthreads_cond);
138 #ifdef EMULATE_ATOMIC_REFCOUNTS
139 MUTEX_INIT(&PL_svref_mutex);
140 #endif /* EMULATE_ATOMIC_REFCOUNTS */
142 MUTEX_INIT(&PL_cred_mutex);
144 thr = init_main_thread();
145 #endif /* USE_THREADS */
147 PL_protect = MEMBER_TO_FPTR(Perl_default_protect); /* for exceptions */
149 PL_curcop = &PL_compiling; /* needed by ckWARN, right away */
151 PL_linestr = NEWSV(65,79);
152 sv_upgrade(PL_linestr,SVt_PVIV);
154 if (!SvREADONLY(&PL_sv_undef)) {
155 /* set read-only and try to insure than we wont see REFCNT==0
158 SvREADONLY_on(&PL_sv_undef);
159 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
161 sv_setpv(&PL_sv_no,PL_No);
163 SvREADONLY_on(&PL_sv_no);
164 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
166 sv_setpv(&PL_sv_yes,PL_Yes);
168 SvREADONLY_on(&PL_sv_yes);
169 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
174 /* PL_sighandlerp = sighandler; */
176 PL_sighandlerp = Perl_sighandler;
178 PL_pidstatus = newHV();
182 * There is no way we can refer to them from Perl so close them to save
183 * space. The other alternative would be to provide STDAUX and STDPRN
186 (void)fclose(stdaux);
187 (void)fclose(stdprn);
191 PL_nrs = newSVpvn("\n", 1);
192 PL_rs = SvREFCNT_inc(PL_nrs);
197 PL_lex_state = LEX_NOTPARSING;
203 SET_NUMERIC_STANDARD();
205 #if defined(PERL_SUBVERSION) && PERL_SUBVERSION > 0
206 sprintf(PL_patchlevel, "%7.5f", (double) PERL_REVISION
207 + ((double) PERL_VERSION / (double) 1000)
208 + ((double) PERL_SUBVERSION / (double) 100000));
210 sprintf(PL_patchlevel, "%5.3f", (double) PERL_REVISION +
211 ((double) PERL_VERSION / (double) 1000));
214 #if defined(LOCAL_PATCH_COUNT)
215 PL_localpatches = local_patches; /* For possible -v */
218 PerlIO_init(); /* Hook to IO system */
220 PL_fdpid = newAV(); /* for remembering popen pids by fd */
221 PL_modglobal = newHV(); /* pointers to per-interpreter module globals */
230 int destruct_level; /* 0=none, 1=full, 2=full with checks */
236 #endif /* USE_THREADS */
240 /* Pass 1 on any remaining threads: detach joinables, join zombies */
242 MUTEX_LOCK(&PL_threads_mutex);
243 DEBUG_S(PerlIO_printf(Perl_debug_log,
244 "perl_destruct: waiting for %d threads...\n",
246 for (t = thr->next; t != thr; t = t->next) {
247 MUTEX_LOCK(&t->mutex);
248 switch (ThrSTATE(t)) {
251 DEBUG_S(PerlIO_printf(Perl_debug_log,
252 "perl_destruct: joining zombie %p\n", t));
253 ThrSETSTATE(t, THRf_DEAD);
254 MUTEX_UNLOCK(&t->mutex);
257 * The SvREFCNT_dec below may take a long time (e.g. av
258 * may contain an object scalar whose destructor gets
259 * called) so we have to unlock threads_mutex and start
262 MUTEX_UNLOCK(&PL_threads_mutex);
264 SvREFCNT_dec((SV*)av);
265 DEBUG_S(PerlIO_printf(Perl_debug_log,
266 "perl_destruct: joined zombie %p OK\n", t));
268 case THRf_R_JOINABLE:
269 DEBUG_S(PerlIO_printf(Perl_debug_log,
270 "perl_destruct: detaching thread %p\n", t));
271 ThrSETSTATE(t, THRf_R_DETACHED);
273 * We unlock threads_mutex and t->mutex in the opposite order
274 * from which we locked them just so that DETACH won't
275 * deadlock if it panics. It's only a breach of good style
276 * not a bug since they are unlocks not locks.
278 MUTEX_UNLOCK(&PL_threads_mutex);
280 MUTEX_UNLOCK(&t->mutex);
283 DEBUG_S(PerlIO_printf(Perl_debug_log,
284 "perl_destruct: ignoring %p (state %u)\n",
286 MUTEX_UNLOCK(&t->mutex);
287 /* fall through and out */
290 /* We leave the above "Pass 1" loop with threads_mutex still locked */
292 /* Pass 2 on remaining threads: wait for the thread count to drop to one */
293 while (PL_nthreads > 1)
295 DEBUG_S(PerlIO_printf(Perl_debug_log,
296 "perl_destruct: final wait for %d threads\n",
298 COND_WAIT(&PL_nthreads_cond, &PL_threads_mutex);
300 /* At this point, we're the last thread */
301 MUTEX_UNLOCK(&PL_threads_mutex);
302 DEBUG_S(PerlIO_printf(Perl_debug_log, "perl_destruct: armageddon has arrived\n"));
303 MUTEX_DESTROY(&PL_threads_mutex);
304 COND_DESTROY(&PL_nthreads_cond);
305 #endif /* !defined(FAKE_THREADS) */
306 #endif /* USE_THREADS */
308 destruct_level = PL_perl_destruct_level;
312 if (s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL")) {
314 if (destruct_level < i)
323 /* We must account for everything. */
325 /* Destroy the main CV and syntax tree */
327 PL_curpad = AvARRAY(PL_comppad);
328 op_free(PL_main_root);
329 PL_main_root = Nullop;
331 PL_curcop = &PL_compiling;
332 PL_main_start = Nullop;
333 SvREFCNT_dec(PL_main_cv);
337 if (PL_sv_objcount) {
339 * Try to destruct global references. We do this first so that the
340 * destructors and destructees still exist. Some sv's might remain.
341 * Non-referenced objects are on their own.
346 /* unhook hooks which will soon be, or use, destroyed data */
347 SvREFCNT_dec(PL_warnhook);
348 PL_warnhook = Nullsv;
349 SvREFCNT_dec(PL_diehook);
352 /* call exit list functions */
353 while (PL_exitlistlen-- > 0)
354 PL_exitlist[PL_exitlistlen].fn(aTHXo_ PL_exitlist[PL_exitlistlen].ptr);
356 Safefree(PL_exitlist);
358 if (destruct_level == 0){
360 DEBUG_P(debprofdump());
362 /* The exit() function will do everything that needs doing. */
366 /* loosen bonds of global variables */
369 (void)PerlIO_close(PL_rsfp);
373 /* Filters for program text */
374 SvREFCNT_dec(PL_rsfp_filters);
375 PL_rsfp_filters = Nullav;
378 PL_preprocess = FALSE;
384 PL_doswitches = FALSE;
385 PL_dowarn = G_WARN_OFF;
386 PL_doextract = FALSE;
387 PL_sawampersand = FALSE; /* must save all match strings */
390 Safefree(PL_inplace);
394 SvREFCNT_dec(PL_e_script);
395 PL_e_script = Nullsv;
398 /* magical thingies */
400 Safefree(PL_ofs); /* $, */
403 Safefree(PL_ors); /* $\ */
406 SvREFCNT_dec(PL_rs); /* $/ */
409 SvREFCNT_dec(PL_nrs); /* $/ helper */
412 PL_multiline = 0; /* $* */
414 SvREFCNT_dec(PL_statname);
415 PL_statname = Nullsv;
418 /* defgv, aka *_ should be taken care of elsewhere */
420 /* clean up after study() */
421 SvREFCNT_dec(PL_lastscream);
422 PL_lastscream = Nullsv;
423 Safefree(PL_screamfirst);
425 Safefree(PL_screamnext);
429 Safefree(PL_efloatbuf);
430 PL_efloatbuf = Nullch;
433 /* startup and shutdown function lists */
434 SvREFCNT_dec(PL_beginav);
435 SvREFCNT_dec(PL_endav);
436 SvREFCNT_dec(PL_initav);
441 /* shortcuts just get cleared */
447 PL_argvoutgv = Nullgv;
449 PL_stderrgv = Nullgv;
450 PL_last_in_gv = Nullgv;
453 /* reset so print() ends up where we expect */
456 /* Prepare to destruct main symbol table. */
462 /* clear queued errors */
463 SvREFCNT_dec(PL_errors);
467 if (destruct_level >= 2 && ckWARN_d(WARN_INTERNAL)) {
468 if (PL_scopestack_ix != 0)
469 Perl_warner(aTHX_ WARN_INTERNAL,
470 "Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
471 (long)PL_scopestack_ix);
472 if (PL_savestack_ix != 0)
473 Perl_warner(aTHX_ WARN_INTERNAL,
474 "Unbalanced saves: %ld more saves than restores\n",
475 (long)PL_savestack_ix);
476 if (PL_tmps_floor != -1)
477 Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced tmps: %ld more allocs than frees\n",
478 (long)PL_tmps_floor + 1);
479 if (cxstack_ix != -1)
480 Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced context: %ld more PUSHes than POPs\n",
481 (long)cxstack_ix + 1);
484 /* Now absolutely destruct everything, somehow or other, loops or no. */
486 SvFLAGS(PL_strtab) |= SVTYPEMASK; /* don't clean out strtab now */
487 while (PL_sv_count != 0 && PL_sv_count != last_sv_count) {
488 last_sv_count = PL_sv_count;
491 SvFLAGS(PL_strtab) &= ~SVTYPEMASK;
492 SvFLAGS(PL_strtab) |= SVt_PVHV;
494 /* Destruct the global string table. */
496 /* Yell and reset the HeVAL() slots that are still holding refcounts,
497 * so that sv_free() won't fail on them.
505 max = HvMAX(PL_strtab);
506 array = HvARRAY(PL_strtab);
509 if (hent && ckWARN_d(WARN_INTERNAL)) {
510 Perl_warner(aTHX_ WARN_INTERNAL,
511 "Unbalanced string table refcount: (%d) for \"%s\"",
512 HeVAL(hent) - Nullsv, HeKEY(hent));
513 HeVAL(hent) = Nullsv;
523 SvREFCNT_dec(PL_strtab);
525 if (PL_sv_count != 0 && ckWARN_d(WARN_INTERNAL))
526 Perl_warner(aTHX_ WARN_INTERNAL,"Scalars leaked: %ld\n", (long)PL_sv_count);
530 /* No SVs have survived, need to clean out */
532 PL_pidstatus = Nullhv;
533 Safefree(PL_origfilename);
534 Safefree(PL_archpat_auto);
535 Safefree(PL_reg_start_tmp);
537 Safefree(PL_reg_curpm);
538 Safefree(PL_reg_poscache);
539 Safefree(HeKEY_hek(&PL_hv_fetch_ent_mh));
540 Safefree(PL_op_mask);
542 PL_hints = 0; /* Reset hints. Should hints be per-interpreter ? */
544 DEBUG_P(debprofdump());
546 MUTEX_DESTROY(&PL_strtab_mutex);
547 MUTEX_DESTROY(&PL_sv_mutex);
548 MUTEX_DESTROY(&PL_eval_mutex);
549 MUTEX_DESTROY(&PL_cred_mutex);
550 COND_DESTROY(&PL_eval_cond);
551 #ifdef EMULATE_ATOMIC_REFCOUNTS
552 MUTEX_DESTROY(&PL_svref_mutex);
553 #endif /* EMULATE_ATOMIC_REFCOUNTS */
555 /* As the penultimate thing, free the non-arena SV for thrsv */
556 Safefree(SvPVX(PL_thrsv));
557 Safefree(SvANY(PL_thrsv));
560 #endif /* USE_THREADS */
562 /* As the absolutely last thing, free the non-arena SV for mess() */
565 /* it could have accumulated taint magic */
566 if (SvTYPE(PL_mess_sv) >= SVt_PVMG) {
569 for (mg = SvMAGIC(PL_mess_sv); mg; mg = moremagic) {
570 moremagic = mg->mg_moremagic;
571 if (mg->mg_ptr && mg->mg_type != 'g' && mg->mg_len >= 0)
572 Safefree(mg->mg_ptr);
576 /* we know that type >= SVt_PV */
577 SvOOK_off(PL_mess_sv);
578 Safefree(SvPVX(PL_mess_sv));
579 Safefree(SvANY(PL_mess_sv));
580 Safefree(PL_mess_sv);
588 #if defined(PERL_OBJECT)
596 Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr)
598 Renew(PL_exitlist, PL_exitlistlen+1, PerlExitListEntry);
599 PL_exitlist[PL_exitlistlen].fn = fn;
600 PL_exitlist[PL_exitlistlen].ptr = ptr;
605 perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env)
615 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
618 Perl_croak(aTHX_ "suidperl is no longer needed since the kernel can now execute\n\
619 setuid perl scripts securely.\n");
623 #if defined(__DYNAMIC__) && (defined(NeXT) || defined(__NeXT__))
624 _dyld_lookup_and_bind
625 ("__environ", (unsigned long *) &environ_pointer, NULL);
630 #ifndef VMS /* VMS doesn't have environ array */
631 PL_origenviron = environ;
636 /* Come here if running an undumped a.out. */
638 PL_origfilename = savepv(argv[0]);
639 PL_do_undump = FALSE;
640 cxstack_ix = -1; /* start label stack again */
642 init_postdump_symbols(argc,argv,env);
647 PL_curpad = AvARRAY(PL_comppad);
648 op_free(PL_main_root);
649 PL_main_root = Nullop;
651 PL_main_start = Nullop;
652 SvREFCNT_dec(PL_main_cv);
656 oldscope = PL_scopestack_ix;
657 PL_dowarn = G_WARN_OFF;
659 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_parse_body),
668 /* my_exit() was called */
669 while (PL_scopestack_ix > oldscope)
672 PL_curstash = PL_defstash;
673 if (PL_endav && !PL_minus_c)
674 call_list(oldscope, PL_endav);
675 return STATUS_NATIVE_EXPORT;
677 PerlIO_printf(Perl_error_log, "panic: top_env\n");
684 S_parse_body(pTHX_ va_list args)
687 int argc = PL_origargc;
688 char **argv = PL_origargv;
689 char **env = va_arg(args, char**);
690 char *scriptname = NULL;
692 VOL bool dosearch = FALSE;
697 char *cddir = Nullch;
699 XSINIT_t xsinit = va_arg(args, XSINIT_t);
701 sv_setpvn(PL_linestr,"",0);
702 sv = newSVpvn("",0); /* first used for -I flags */
706 for (argc--,argv++; argc > 0; argc--,argv++) {
707 if (argv[0][0] != '-' || !argv[0][1])
711 validarg = " PHOOEY ";
718 #ifndef PERL_STRICT_CR
742 if (s = moreswitches(s))
752 if (PL_euid != PL_uid || PL_egid != PL_gid)
753 Perl_croak(aTHX_ "No -e allowed in setuid scripts");
755 PL_e_script = newSVpvn("",0);
756 filter_add(read_e_script, NULL);
759 sv_catpv(PL_e_script, s);
761 sv_catpv(PL_e_script, argv[1]);
765 Perl_croak(aTHX_ "No code specified for -e");
766 sv_catpv(PL_e_script, "\n");
769 case 'I': /* -I handled both here and in moreswitches() */
771 if (!*++s && (s=argv[1]) != Nullch) {
774 while (s && isSPACE(*s))
778 for (e = s; *e && !isSPACE(*e); e++) ;
785 } /* XXX else croak? */
789 PL_preprocess = TRUE;
799 PL_preambleav = newAV();
800 av_push(PL_preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
802 PL_Sv = newSVpv("print myconfig();",0);
804 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
806 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
808 sv_catpv(PL_Sv,"\" Compile-time options:");
810 sv_catpv(PL_Sv," DEBUGGING");
813 sv_catpv(PL_Sv," MULTIPLICITY");
816 sv_catpv(PL_Sv," USE_THREADS");
819 sv_catpv(PL_Sv," PERL_OBJECT");
821 # ifdef PERL_IMPLICIT_CONTEXT
822 sv_catpv(PL_Sv," PERL_IMPLICIT_CONTEXT");
824 # ifdef PERL_IMPLICIT_SYS
825 sv_catpv(PL_Sv," PERL_IMPLICIT_SYS");
827 sv_catpv(PL_Sv,"\\n\",");
829 #if defined(LOCAL_PATCH_COUNT)
830 if (LOCAL_PATCH_COUNT > 0) {
832 sv_catpv(PL_Sv,"\" Locally applied patches:\\n\",");
833 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
834 if (PL_localpatches[i])
835 Perl_sv_catpvf(aTHX_ PL_Sv,"q\" \t%s\n\",",PL_localpatches[i]);
839 Perl_sv_catpvf(aTHX_ PL_Sv,"\" Built under %s\\n\"",OSNAME);
842 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
844 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled on %s\\n\"",__DATE__);
849 @env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; \
850 print \" \\%ENV:\\n @env\\n\" if @env; \
851 print \" \\@INC:\\n @INC\\n\";");
854 PL_Sv = newSVpv("config_vars(qw(",0);
855 sv_catpv(PL_Sv, ++s);
856 sv_catpv(PL_Sv, "))");
859 av_push(PL_preambleav, PL_Sv);
860 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
871 if (!*++s || isSPACE(*s)) {
875 /* catch use of gnu style long options */
876 if (strEQ(s, "version")) {
880 if (strEQ(s, "help")) {
887 Perl_croak(aTHX_ "Unrecognized switch: -%s (-h will show valid options)",s);
893 #ifndef SECURE_INTERNAL_GETENV
896 (s = PerlEnv_getenv("PERL5OPT"))) {
899 if (*s == '-' && *(s+1) == 'T')
912 if (!strchr("DIMUdmw", *s))
913 Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s);
920 scriptname = argv[0];
923 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
925 else if (scriptname == Nullch) {
927 if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
935 open_script(scriptname,dosearch,sv,&fdscript);
937 validate_suid(validarg, scriptname,fdscript);
939 #if defined(SIGCHLD) || defined(SIGCLD)
942 # define SIGCHLD SIGCLD
944 Sighandler_t sigstate = rsignal_state(SIGCHLD);
945 if (sigstate == SIG_IGN) {
946 if (ckWARN(WARN_SIGNAL))
947 Perl_warner(aTHX_ WARN_SIGNAL,
948 "Can't ignore signal CHLD, forcing to default");
949 (void)rsignal(SIGCHLD, (Sighandler_t)SIG_DFL);
956 if (cddir && PerlDir_chdir(cddir) < 0)
957 Perl_croak(aTHX_ "Can't chdir to %s",cddir);
961 PL_main_cv = PL_compcv = (CV*)NEWSV(1104,0);
962 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
963 CvUNIQUE_on(PL_compcv);
965 PL_comppad = newAV();
966 av_push(PL_comppad, Nullsv);
967 PL_curpad = AvARRAY(PL_comppad);
968 PL_comppad_name = newAV();
969 PL_comppad_name_fill = 0;
970 PL_min_intro_pending = 0;
973 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
974 PL_curpad[0] = (SV*)newAV();
975 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
976 CvOWNER(PL_compcv) = 0;
977 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
978 MUTEX_INIT(CvMUTEXP(PL_compcv));
979 #endif /* USE_THREADS */
981 comppadlist = newAV();
982 AvREAL_off(comppadlist);
983 av_store(comppadlist, 0, (SV*)PL_comppad_name);
984 av_store(comppadlist, 1, (SV*)PL_comppad);
985 CvPADLIST(PL_compcv) = comppadlist;
987 boot_core_UNIVERSAL();
991 (*xsinit)(aTHXo); /* in case linked C routines want magical variables */
992 #if defined(VMS) || defined(WIN32) || defined(DJGPP)
1000 init_predump_symbols();
1001 /* init_postdump_symbols not currently designed to be called */
1002 /* more than once (ENV isn't cleared first, for example) */
1003 /* But running with -u leaves %ENV & @ARGV undefined! XXX */
1005 init_postdump_symbols(argc,argv,env);
1009 /* now parse the script */
1011 SETERRNO(0,SS$_NORMAL);
1013 if (yyparse() || PL_error_count) {
1015 Perl_croak(aTHX_ "%s had compilation errors.\n", PL_origfilename);
1017 Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
1021 PL_curcop->cop_line = 0;
1022 PL_curstash = PL_defstash;
1023 PL_preprocess = FALSE;
1025 SvREFCNT_dec(PL_e_script);
1026 PL_e_script = Nullsv;
1029 /* now that script is parsed, we can modify record separator */
1030 SvREFCNT_dec(PL_rs);
1031 PL_rs = SvREFCNT_inc(PL_nrs);
1032 sv_setsv(get_sv("/", TRUE), PL_rs);
1037 gv_check(PL_defstash);
1043 if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
1044 dump_mstats("after compilation:");
1063 oldscope = PL_scopestack_ix;
1066 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_run_body), oldscope);
1069 cxstack_ix = -1; /* start context stack again */
1071 case 0: /* normal completion */
1072 case 2: /* my_exit() */
1073 while (PL_scopestack_ix > oldscope)
1076 PL_curstash = PL_defstash;
1077 if (PL_endav && !PL_minus_c)
1078 call_list(oldscope, PL_endav);
1080 if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
1081 dump_mstats("after execution: ");
1083 return STATUS_NATIVE_EXPORT;
1086 POPSTACK_TO(PL_mainstack);
1089 PerlIO_printf(Perl_error_log, "panic: restartop\n");
1099 S_run_body(pTHX_ va_list args)
1102 I32 oldscope = va_arg(args, I32);
1104 DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
1105 PL_sawampersand ? "Enabling" : "Omitting"));
1107 if (!PL_restartop) {
1108 DEBUG_x(dump_all());
1109 DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
1110 DEBUG_S(PerlIO_printf(Perl_debug_log, "main thread is 0x%"UVxf"\n",
1114 PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename);
1117 if (PERLDB_SINGLE && PL_DBsingle)
1118 sv_setiv(PL_DBsingle, 1);
1120 call_list(oldscope, PL_initav);
1126 PL_op = PL_restartop;
1130 else if (PL_main_start) {
1131 CvDEPTH(PL_main_cv) = 1;
1132 PL_op = PL_main_start;
1142 Perl_get_sv(pTHX_ const char *name, I32 create)
1146 if (name[1] == '\0' && !isALPHA(name[0])) {
1147 PADOFFSET tmp = find_threadsv(name);
1148 if (tmp != NOT_IN_PAD) {
1150 return THREADSV(tmp);
1153 #endif /* USE_THREADS */
1154 gv = gv_fetchpv(name, create, SVt_PV);
1161 Perl_get_av(pTHX_ const char *name, I32 create)
1163 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
1172 Perl_get_hv(pTHX_ const char *name, I32 create)
1174 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
1183 Perl_get_cv(pTHX_ const char *name, I32 create)
1185 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
1186 /* XXX unsafe for threads if eval_owner isn't held */
1187 /* XXX this is probably not what they think they're getting.
1188 * It has the same effect as "sub name;", i.e. just a forward
1190 if (create && !GvCVu(gv))
1191 return newSUB(start_subparse(FALSE, 0),
1192 newSVOP(OP_CONST, 0, newSVpv(name,0)),
1200 /* Be sure to refetch the stack pointer after calling these routines. */
1203 Perl_call_argv(pTHX_ const char *sub_name, I32 flags, register char **argv)
1205 /* See G_* flags in cop.h */
1206 /* null terminated arg list */
1213 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
1218 return call_pv(sub_name, flags);
1222 Perl_call_pv(pTHX_ const char *sub_name, I32 flags)
1223 /* name of the subroutine */
1224 /* See G_* flags in cop.h */
1226 return call_sv((SV*)get_cv(sub_name, TRUE), flags);
1230 Perl_call_method(pTHX_ const char *methname, I32 flags)
1231 /* name of the subroutine */
1232 /* See G_* flags in cop.h */
1238 XPUSHs(sv_2mortal(newSVpv(methname,0)));
1243 return call_sv(*PL_stack_sp--, flags);
1246 /* May be called with any of a CV, a GV, or an SV containing the name. */
1248 Perl_call_sv(pTHX_ SV *sv, I32 flags)
1250 /* See G_* flags in cop.h */
1253 LOGOP myop; /* fake syntax tree node */
1257 bool oldcatch = CATCH_GET;
1262 if (flags & G_DISCARD) {
1267 Zero(&myop, 1, LOGOP);
1268 myop.op_next = Nullop;
1269 if (!(flags & G_NOARGS))
1270 myop.op_flags |= OPf_STACKED;
1271 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1272 (flags & G_ARRAY) ? OPf_WANT_LIST :
1277 EXTEND(PL_stack_sp, 1);
1278 *++PL_stack_sp = sv;
1280 oldscope = PL_scopestack_ix;
1282 if (PERLDB_SUB && PL_curstash != PL_debstash
1283 /* Handle first BEGIN of -d. */
1284 && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub)))
1285 /* Try harder, since this may have been a sighandler, thus
1286 * curstash may be meaningless. */
1287 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != PL_debstash)
1288 && !(flags & G_NODEBUG))
1289 PL_op->op_private |= OPpENTERSUB_DB;
1291 if (!(flags & G_EVAL)) {
1293 call_xbody((OP*)&myop, FALSE);
1294 retval = PL_stack_sp - (PL_stack_base + oldmark);
1295 CATCH_SET(oldcatch);
1298 cLOGOP->op_other = PL_op;
1300 /* we're trying to emulate pp_entertry() here */
1302 register PERL_CONTEXT *cx;
1303 I32 gimme = GIMME_V;
1308 push_return(PL_op->op_next);
1309 PUSHBLOCK(cx, CXt_EVAL, PL_stack_sp);
1311 PL_eval_root = PL_op; /* Only needed so that goto works right. */
1313 PL_in_eval = EVAL_INEVAL;
1314 if (flags & G_KEEPERR)
1315 PL_in_eval |= EVAL_KEEPERR;
1322 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_call_body),
1326 retval = PL_stack_sp - (PL_stack_base + oldmark);
1327 if (!(flags & G_KEEPERR))
1334 /* my_exit() was called */
1335 PL_curstash = PL_defstash;
1338 Perl_croak(aTHX_ "Callback called exit");
1343 PL_op = PL_restartop;
1347 PL_stack_sp = PL_stack_base + oldmark;
1348 if (flags & G_ARRAY)
1352 *++PL_stack_sp = &PL_sv_undef;
1357 if (PL_scopestack_ix > oldscope) {
1361 register PERL_CONTEXT *cx;
1372 if (flags & G_DISCARD) {
1373 PL_stack_sp = PL_stack_base + oldmark;
1383 S_call_body(pTHX_ va_list args)
1385 OP *myop = va_arg(args, OP*);
1386 int is_eval = va_arg(args, int);
1388 call_xbody(myop, is_eval);
1393 S_call_xbody(pTHX_ OP *myop, int is_eval)
1397 if (PL_op == myop) {
1399 PL_op = Perl_pp_entereval(aTHX);
1401 PL_op = Perl_pp_entersub(aTHX);
1407 /* Eval a string. The G_EVAL flag is always assumed. */
1410 Perl_eval_sv(pTHX_ SV *sv, I32 flags)
1412 /* See G_* flags in cop.h */
1415 UNOP myop; /* fake syntax tree node */
1416 I32 oldmark = SP - PL_stack_base;
1423 if (flags & G_DISCARD) {
1430 Zero(PL_op, 1, UNOP);
1431 EXTEND(PL_stack_sp, 1);
1432 *++PL_stack_sp = sv;
1433 oldscope = PL_scopestack_ix;
1435 if (!(flags & G_NOARGS))
1436 myop.op_flags = OPf_STACKED;
1437 myop.op_next = Nullop;
1438 myop.op_type = OP_ENTEREVAL;
1439 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1440 (flags & G_ARRAY) ? OPf_WANT_LIST :
1442 if (flags & G_KEEPERR)
1443 myop.op_flags |= OPf_SPECIAL;
1446 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_call_body),
1450 retval = PL_stack_sp - (PL_stack_base + oldmark);
1451 if (!(flags & G_KEEPERR))
1458 /* my_exit() was called */
1459 PL_curstash = PL_defstash;
1462 Perl_croak(aTHX_ "Callback called exit");
1467 PL_op = PL_restartop;
1471 PL_stack_sp = PL_stack_base + oldmark;
1472 if (flags & G_ARRAY)
1476 *++PL_stack_sp = &PL_sv_undef;
1481 if (flags & G_DISCARD) {
1482 PL_stack_sp = PL_stack_base + oldmark;
1492 Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
1495 SV* sv = newSVpv(p, 0);
1498 eval_sv(sv, G_SCALAR);
1505 if (croak_on_error && SvTRUE(ERRSV)) {
1507 Perl_croak(aTHX_ SvPVx(ERRSV, n_a));
1513 /* Require a module. */
1516 Perl_require_pv(pTHX_ const char *pv)
1520 PUSHSTACKi(PERLSI_REQUIRE);
1522 sv = sv_newmortal();
1523 sv_setpv(sv, "require '");
1526 eval_sv(sv, G_DISCARD);
1532 Perl_magicname(pTHX_ char *sym, char *name, I32 namlen)
1536 if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
1537 sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1541 S_usage(pTHX_ char *name) /* XXX move this out into a module ? */
1543 /* This message really ought to be max 23 lines.
1544 * Removed -h because the user already knows that opton. Others? */
1546 static char *usage_msg[] = {
1547 "-0[octal] specify record separator (\\0, if no argument)",
1548 "-a autosplit mode with -n or -p (splits $_ into @F)",
1549 "-c check syntax only (runs BEGIN and END blocks)",
1550 "-d[:debugger] run program under debugger",
1551 "-D[number/list] set debugging flags (argument is a bit mask or alphabets)",
1552 "-e 'command' one line of program (several -e's allowed, omit programfile)",
1553 "-F/pattern/ split() pattern for -a switch (//'s are optional)",
1554 "-i[extension] edit <> files in place (makes backup if extension supplied)",
1555 "-Idirectory specify @INC/#include directory (several -I's allowed)",
1556 "-l[octal] enable line ending processing, specifies line terminator",
1557 "-[mM][-]module execute `use/no module...' before executing program",
1558 "-n assume 'while (<>) { ... }' loop around program",
1559 "-p assume loop like -n but print line also, like sed",
1560 "-P run program through C preprocessor before compilation",
1561 "-s enable rudimentary parsing for switches after programfile",
1562 "-S look for programfile using PATH environment variable",
1563 "-T enable tainting checks",
1564 "-u dump core after parsing program",
1565 "-U allow unsafe operations",
1566 "-v print version, subversion (includes VERY IMPORTANT perl info)",
1567 "-V[:variable] print configuration summary (or a single Config.pm variable)",
1568 "-w enable many useful warnings (RECOMMENDED)",
1569 "-x[directory] strip off text before #!perl line and perhaps cd to directory",
1573 char **p = usage_msg;
1575 printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
1577 printf("\n %s", *p++);
1580 /* This routine handles any switches that can be given during run */
1583 Perl_moreswitches(pTHX_ char *s)
1592 rschar = (U32)scan_oct(s, 4, &numlen);
1593 SvREFCNT_dec(PL_nrs);
1594 if (rschar & ~((U8)~0))
1595 PL_nrs = &PL_sv_undef;
1596 else if (!rschar && numlen >= 2)
1597 PL_nrs = newSVpvn("", 0);
1600 PL_nrs = newSVpvn(&ch, 1);
1606 PL_splitstr = savepv(s + 1);
1620 if (*s == ':' || *s == '=') {
1621 my_setenv("PERL5DB", Perl_form(aTHX_ "use Devel::%s;", ++s));
1625 PL_perldb = PERLDB_ALL;
1633 if (isALPHA(s[1])) {
1634 static char debopts[] = "psltocPmfrxuLHXDS";
1637 for (s++; *s && (d = strchr(debopts,*s)); s++)
1638 PL_debug |= 1 << (d - debopts);
1641 PL_debug = atoi(s+1);
1642 for (s++; isDIGIT(*s); s++) ;
1644 PL_debug |= 0x80000000;
1647 if (ckWARN_d(WARN_DEBUGGING))
1648 Perl_warner(aTHX_ WARN_DEBUGGING,
1649 "Recompile perl with -DDEBUGGING to use -D switch\n");
1650 for (s++; isALNUM(*s); s++) ;
1656 usage(PL_origargv[0]);
1660 Safefree(PL_inplace);
1661 PL_inplace = savepv(s+1);
1663 for (s = PL_inplace; *s && !isSPACE(*s); s++) ;
1666 if (*s == '-') /* Additional switches on #! line. */
1670 case 'I': /* -I handled both here and in parse_perl() */
1673 while (*s && isSPACE(*s))
1677 for (e = s; *e && !isSPACE(*e); e++) ;
1678 p = savepvn(s, e-s);
1684 Perl_croak(aTHX_ "No space allowed after -I");
1692 PL_ors = savepv("\n");
1694 *PL_ors = (char)scan_oct(s, 3 + (*s == '0'), &numlen);
1699 if (RsPARA(PL_nrs)) {
1704 PL_ors = SvPV(PL_nrs, PL_orslen);
1705 PL_ors = savepvn(PL_ors, PL_orslen);
1709 forbid_setid("-M"); /* XXX ? */
1712 forbid_setid("-m"); /* XXX ? */
1717 /* -M-foo == 'no foo' */
1718 if (*s == '-') { use = "no "; ++s; }
1719 sv = newSVpv(use,0);
1721 /* We allow -M'Module qw(Foo Bar)' */
1722 while(isALNUM(*s) || *s==':') ++s;
1724 sv_catpv(sv, start);
1725 if (*(start-1) == 'm') {
1727 Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
1728 sv_catpv( sv, " ()");
1731 sv_catpvn(sv, start, s-start);
1732 sv_catpv(sv, " split(/,/,q{");
1737 if (PL_preambleav == NULL)
1738 PL_preambleav = newAV();
1739 av_push(PL_preambleav, sv);
1742 Perl_croak(aTHX_ "No space allowed after -%c", *(s-1));
1754 PL_doswitches = TRUE;
1759 Perl_croak(aTHX_ "Too late for \"-T\" option");
1763 PL_do_undump = TRUE;
1771 #if defined(PERL_SUBVERSION) && PERL_SUBVERSION > 0
1772 printf("\nThis is perl, version %d.%03d_%02d built for %s",
1773 PERL_REVISION, PERL_VERSION, PERL_SUBVERSION, ARCHNAME);
1775 printf("\nThis is perl, version %s built for %s",
1776 PL_patchlevel, ARCHNAME);
1778 #if defined(LOCAL_PATCH_COUNT)
1779 if (LOCAL_PATCH_COUNT > 0)
1780 printf("\n(with %d registered patch%s, see perl -V for more detail)",
1781 (int)LOCAL_PATCH_COUNT, (LOCAL_PATCH_COUNT!=1) ? "es" : "");
1784 printf("\n\nCopyright 1987-1999, Larry Wall\n");
1786 printf("\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
1789 printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
1790 printf("djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
1793 printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
1794 "Version 5 port Copyright (c) 1994-1999, Andreas Kaiser, Ilya Zakharevich\n");
1797 printf("atariST series port, ++jrb bammi@cadence.com\n");
1800 printf("BeOS port Copyright Tom Spindler, 1997-1999\n");
1803 printf("MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-1999\n");
1806 printf("MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
1809 printf("Stratus VOS port by Paul_Green@stratus.com, 1997-1999\n");
1812 printf("VM/ESA port by Neale Ferguson, 1998-1999\n");
1815 printf("BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
1818 printf("MiNT port by Guido Flohr, 1997-1999\n");
1820 #ifdef BINARY_BUILD_NOTICE
1821 BINARY_BUILD_NOTICE;
1824 Perl may be copied only under the terms of either the Artistic License or the\n\
1825 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n\
1826 Complete documentation for Perl, including FAQ lists, should be found on\n\
1827 this system using `man perl' or `perldoc perl'. If you have access to the\n\
1828 Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n");
1831 if (! (PL_dowarn & G_WARN_ALL_MASK))
1832 PL_dowarn |= G_WARN_ON;
1836 PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
1837 PL_compiling.cop_warnings = WARN_ALL ;
1841 PL_dowarn = G_WARN_ALL_OFF;
1842 PL_compiling.cop_warnings = WARN_NONE ;
1847 if (s[1] == '-') /* Additional switches on #! line. */
1852 #if defined(WIN32) || !defined(PERL_STRICT_CR)
1858 #ifdef ALTERNATE_SHEBANG
1859 case 'S': /* OS/2 needs -S on "extproc" line. */
1867 Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
1872 /* compliments of Tom Christiansen */
1874 /* unexec() can be found in the Gnu emacs distribution */
1875 /* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
1878 Perl_my_unexec(pTHX)
1886 prog = newSVpv(BIN_EXP, 0);
1887 sv_catpv(prog, "/perl");
1888 file = newSVpv(PL_origfilename, 0);
1889 sv_catpv(file, ".perldump");
1891 unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
1892 /* unexec prints msg to stderr in case of failure */
1893 PerlProc_exit(status);
1896 # include <lib$routines.h>
1897 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
1899 ABORT(); /* for use with undump */
1904 /* initialize curinterp */
1909 #ifdef PERL_OBJECT /* XXX kludge */
1912 PL_chopset = " \n-"; \
1913 PL_copline = NOLINE; \
1914 PL_curcop = &PL_compiling;\
1915 PL_curcopdb = NULL; \
1917 PL_dumpindent = 4; \
1918 PL_laststatval = -1; \
1919 PL_laststype = OP_STAT; \
1920 PL_maxscream = -1; \
1921 PL_maxsysfd = MAXSYSFD; \
1922 PL_statname = Nullsv; \
1923 PL_tmps_floor = -1; \
1925 PL_op_mask = NULL; \
1926 PL_laststatval = -1; \
1927 PL_laststype = OP_STAT; \
1928 PL_mess_sv = Nullsv; \
1929 PL_splitstr = " "; \
1930 PL_generation = 100; \
1931 PL_exitlist = NULL; \
1932 PL_exitlistlen = 0; \
1934 PL_in_clean_objs = FALSE; \
1935 PL_in_clean_all = FALSE; \
1936 PL_profiledata = NULL; \
1938 PL_rsfp_filters = Nullav; \
1943 # ifdef MULTIPLICITY
1944 # define PERLVAR(var,type)
1945 # define PERLVARA(var,n,type)
1946 # if defined(PERL_IMPLICIT_CONTEXT)
1947 # if defined(USE_THREADS)
1948 # define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
1949 # define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
1950 # else /* !USE_THREADS */
1951 # define PERLVARI(var,type,init) aTHX->var = init;
1952 # define PERLVARIC(var,type,init) aTHX->var = init;
1953 # endif /* USE_THREADS */
1955 # define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
1956 # define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
1958 # include "intrpvar.h"
1959 # ifndef USE_THREADS
1960 # include "thrdvar.h"
1967 # define PERLVAR(var,type)
1968 # define PERLVARA(var,n,type)
1969 # define PERLVARI(var,type,init) PL_##var = init;
1970 # define PERLVARIC(var,type,init) PL_##var = init;
1971 # include "intrpvar.h"
1972 # ifndef USE_THREADS
1973 # include "thrdvar.h"
1985 S_init_main_stash(pTHX)
1990 /* Note that strtab is a rather special HV. Assumptions are made
1991 about not iterating on it, and not adding tie magic to it.
1992 It is properly deallocated in perl_destruct() */
1993 PL_strtab = newHV();
1995 MUTEX_INIT(&PL_strtab_mutex);
1997 HvSHAREKEYS_off(PL_strtab); /* mandatory */
1998 hv_ksplit(PL_strtab, 512);
2000 PL_curstash = PL_defstash = newHV();
2001 PL_curstname = newSVpvn("main",4);
2002 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
2003 SvREFCNT_dec(GvHV(gv));
2004 GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);
2006 HvNAME(PL_defstash) = savepv("main");
2007 PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
2008 GvMULTI_on(PL_incgv);
2009 PL_hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */
2010 GvMULTI_on(PL_hintgv);
2011 PL_defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
2012 PL_errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
2013 GvMULTI_on(PL_errgv);
2014 PL_replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */
2015 GvMULTI_on(PL_replgv);
2016 (void)Perl_form(aTHX_ "%240s",""); /* Preallocate temp - for immediate signals. */
2017 sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
2018 sv_setpvn(ERRSV, "", 0);
2019 PL_curstash = PL_defstash;
2020 PL_compiling.cop_stash = PL_defstash;
2021 PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
2022 PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
2023 /* We must init $/ before switches are processed. */
2024 sv_setpvn(get_sv("/", TRUE), "\n", 1);
2028 S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript)
2036 PL_origfilename = savepv("-e");
2039 /* if find_script() returns, it returns a malloc()-ed value */
2040 PL_origfilename = scriptname = find_script(scriptname, dosearch, NULL, 1);
2042 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
2043 char *s = scriptname + 8;
2044 *fdscript = atoi(s);
2048 scriptname = savepv(s + 1);
2049 Safefree(PL_origfilename);
2050 PL_origfilename = scriptname;
2055 PL_curcop->cop_filegv = gv_fetchfile(PL_origfilename);
2056 if (strEQ(PL_origfilename,"-"))
2058 if (*fdscript >= 0) {
2059 PL_rsfp = PerlIO_fdopen(*fdscript,PERL_SCRIPT_MODE);
2060 #if defined(HAS_FCNTL) && defined(F_SETFD)
2062 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1); /* ensure close-on-exec */
2065 else if (PL_preprocess) {
2066 char *cpp_cfg = CPPSTDIN;
2067 SV *cpp = newSVpvn("",0);
2068 SV *cmd = NEWSV(0,0);
2070 if (strEQ(cpp_cfg, "cppstdin"))
2071 Perl_sv_catpvf(aTHX_ cpp, "%s/", BIN_EXP);
2072 sv_catpv(cpp, cpp_cfg);
2075 sv_catpv(sv,PRIVLIB_EXP);
2078 Perl_sv_setpvf(aTHX_ cmd, "\
2079 sed %s -e \"/^[^#]/b\" \
2080 -e \"/^#[ ]*include[ ]/b\" \
2081 -e \"/^#[ ]*define[ ]/b\" \
2082 -e \"/^#[ ]*if[ ]/b\" \
2083 -e \"/^#[ ]*ifdef[ ]/b\" \
2084 -e \"/^#[ ]*ifndef[ ]/b\" \
2085 -e \"/^#[ ]*else/b\" \
2086 -e \"/^#[ ]*elif[ ]/b\" \
2087 -e \"/^#[ ]*undef[ ]/b\" \
2088 -e \"/^#[ ]*endif/b\" \
2091 (PL_doextract ? "-e \"1,/^#/d\n\"" : ""),
2094 Perl_sv_setpvf(aTHX_ cmd, "\
2095 %s %s -e '/^[^#]/b' \
2096 -e '/^#[ ]*include[ ]/b' \
2097 -e '/^#[ ]*define[ ]/b' \
2098 -e '/^#[ ]*if[ ]/b' \
2099 -e '/^#[ ]*ifdef[ ]/b' \
2100 -e '/^#[ ]*ifndef[ ]/b' \
2101 -e '/^#[ ]*else/b' \
2102 -e '/^#[ ]*elif[ ]/b' \
2103 -e '/^#[ ]*undef[ ]/b' \
2104 -e '/^#[ ]*endif/b' \
2108 Perl_sv_setpvf(aTHX_ cmd, "\
2109 %s %s -e '/^[^#]/b' \
2110 -e '/^#[ ]*include[ ]/b' \
2111 -e '/^#[ ]*define[ ]/b' \
2112 -e '/^#[ ]*if[ ]/b' \
2113 -e '/^#[ ]*ifdef[ ]/b' \
2114 -e '/^#[ ]*ifndef[ ]/b' \
2115 -e '/^#[ ]*else/b' \
2116 -e '/^#[ ]*elif[ ]/b' \
2117 -e '/^#[ ]*undef[ ]/b' \
2118 -e '/^#[ ]*endif/b' \
2127 (PL_doextract ? "-e '1,/^#/d\n'" : ""),
2129 scriptname, cpp, sv, CPPMINUS);
2130 PL_doextract = FALSE;
2131 #ifdef IAMSUID /* actually, this is caught earlier */
2132 if (PL_euid != PL_uid && !PL_euid) { /* if running suidperl */
2134 (void)seteuid(PL_uid); /* musn't stay setuid root */
2137 (void)setreuid((Uid_t)-1, PL_uid);
2139 #ifdef HAS_SETRESUID
2140 (void)setresuid((Uid_t)-1, PL_uid, (Uid_t)-1);
2142 PerlProc_setuid(PL_uid);
2146 if (PerlProc_geteuid() != PL_uid)
2147 Perl_croak(aTHX_ "Can't do seteuid!\n");
2149 #endif /* IAMSUID */
2150 PL_rsfp = PerlProc_popen(SvPVX(cmd), "r");
2154 else if (!*scriptname) {
2155 forbid_setid("program input from stdin");
2156 PL_rsfp = PerlIO_stdin();
2159 PL_rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
2160 #if defined(HAS_FCNTL) && defined(F_SETFD)
2162 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1); /* ensure close-on-exec */
2167 #ifndef IAMSUID /* in case script is not readable before setuid */
2169 PerlLIO_stat(SvPVX(GvSV(PL_curcop->cop_filegv)),&PL_statbuf) >= 0 &&
2170 PL_statbuf.st_mode & (S_ISUID|S_ISGID))
2173 PerlProc_execv(Perl_form(aTHX_ "%s/sperl%s", BIN_EXP, PL_patchlevel), PL_origargv);
2174 Perl_croak(aTHX_ "Can't do setuid\n");
2178 Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
2179 SvPVX(GvSV(PL_curcop->cop_filegv)), Strerror(errno));
2184 * I_SYSSTATVFS HAS_FSTATVFS
2186 * I_STATFS HAS_FSTATFS
2187 * I_MNTENT HAS_GETMNTENT HAS_HASMNTOPT
2188 * here so that metaconfig picks them up. */
2192 S_fd_on_nosuid_fs(pTHX_ int fd)
2194 int check_okay = 0; /* able to do all the required sys/libcalls */
2195 int on_nosuid = 0; /* the fd is on a nosuid fs */
2197 * Preferred order: fstatvfs(), fstatfs(), ustat()+statfs(), getmntent().
2198 * fstatvfs() is UNIX98.
2199 * fstatfs() is 4.3 BSD.
2200 * ustat()+statfs() is pre-4.3 BSD.
2201 * getmntent() is O(number-of-mounted-filesystems) and can hang on
2202 * an irrelevant filesystem while trying to reach the right one.
2205 # ifdef HAS_FSTATVFS
2206 struct statvfs stfs;
2207 check_okay = fstatvfs(fd, &stfs) == 0;
2208 on_nosuid = check_okay && (stfs.f_flag & ST_NOSUID);
2210 # ifdef PERL_MOUNT_NOSUID
2211 # if defined(HAS_FSTATFS) && defined(HAS_STRUCT_STATFS_F_FLAGS)
2213 check_okay = fstatfs(fd, &stfs) == 0;
2214 on_nosuid = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID);
2216 # if defined(HAS_FSTAT) && \
2217 defined(HAS_USTAT) && \
2218 defined(HAS_STATFS) && \
2219 defined(HAS_STRUCT_FS_DATA) /* no struct statfs */
2221 if (fstat(fd, &fdst) == 0) {
2223 if (ustat(fdst.st_dev, &us) == 0) {
2225 if (statfs(PL_origfilename, &fsd) == 0) {
2226 size_t cmplen = sizeof(us.f_fname);
2227 if (sizeof(fsd.fd_req.path) < cmplen)
2228 cmplen = sizeof(fsd.fd_req.path);
2229 if (strnEQ(fsd.fd_req.path, us.f_fname, cmplen) &&
2230 fdst.st_dev == fsd.fd_req.dev) {
2232 on_nosuid = fsd.fd_req.flags & PERL_MOUNT_NOSUID;
2238 # endif /* fstat+ustat+statfs */
2239 # endif /* statfs */
2241 # if defined(HAS_GETMNTENT) && \
2242 defined(HAS_HASMNTOPT) && \
2243 defined(MNTOPT_NOSUID)
2244 FILE *mtab = fopen("/etc/mtab", "r");
2245 struct mntent *entry;
2246 struct stat stb, fsb;
2248 if (mtab && (fstat(fd, &stb) == 0)) {
2249 while (entry = getmntent(mtab)) {
2250 if (stat(entry->mnt_dir, &fsb) == 0
2251 && fsb.st_dev == stb.st_dev)
2253 /* found the filesystem */
2255 if (hasmntopt(entry, MNTOPT_NOSUID))
2258 } /* A single fs may well fail its stat(). */
2263 # endif /* getmntent */
2264 # endif /* PERL_MOUNT_NOSUID: fstatfs or fstat+ustat+statfs */
2265 # endif /* statvfs */
2268 Perl_croak(aTHX_ "Can't check filesystem of script \"%s\" for nosuid", PL_origfilename);
2271 #endif /* IAMSUID */
2274 S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript)
2278 /* do we need to emulate setuid on scripts? */
2280 /* This code is for those BSD systems that have setuid #! scripts disabled
2281 * in the kernel because of a security problem. Merely defining DOSUID
2282 * in perl will not fix that problem, but if you have disabled setuid
2283 * scripts in the kernel, this will attempt to emulate setuid and setgid
2284 * on scripts that have those now-otherwise-useless bits set. The setuid
2285 * root version must be called suidperl or sperlN.NNN. If regular perl
2286 * discovers that it has opened a setuid script, it calls suidperl with
2287 * the same argv that it had. If suidperl finds that the script it has
2288 * just opened is NOT setuid root, it sets the effective uid back to the
2289 * uid. We don't just make perl setuid root because that loses the
2290 * effective uid we had before invoking perl, if it was different from the
2293 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
2294 * be defined in suidperl only. suidperl must be setuid root. The
2295 * Configure script will set this up for you if you want it.
2302 if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0) /* normal stat is insecure */
2303 Perl_croak(aTHX_ "Can't stat script \"%s\"",PL_origfilename);
2304 if (fdscript < 0 && PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
2309 #ifndef HAS_SETREUID
2310 /* On this access check to make sure the directories are readable,
2311 * there is actually a small window that the user could use to make
2312 * filename point to an accessible directory. So there is a faint
2313 * chance that someone could execute a setuid script down in a
2314 * non-accessible directory. I don't know what to do about that.
2315 * But I don't think it's too important. The manual lies when
2316 * it says access() is useful in setuid programs.
2318 if (PerlLIO_access(SvPVX(GvSV(PL_curcop->cop_filegv)),1)) /*double check*/
2319 Perl_croak(aTHX_ "Permission denied");
2321 /* If we can swap euid and uid, then we can determine access rights
2322 * with a simple stat of the file, and then compare device and
2323 * inode to make sure we did stat() on the same file we opened.
2324 * Then we just have to make sure he or she can execute it.
2327 struct stat tmpstatbuf;
2331 setreuid(PL_euid,PL_uid) < 0
2334 setresuid(PL_euid,PL_uid,(Uid_t)-1) < 0
2337 || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
2338 Perl_croak(aTHX_ "Can't swap uid and euid"); /* really paranoid */
2339 if (PerlLIO_stat(SvPVX(GvSV(PL_curcop->cop_filegv)),&tmpstatbuf) < 0)
2340 Perl_croak(aTHX_ "Permission denied"); /* testing full pathname here */
2341 #if defined(IAMSUID) && !defined(NO_NOSUID_CHECK)
2342 if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp)))
2343 Perl_croak(aTHX_ "Permission denied");
2345 if (tmpstatbuf.st_dev != PL_statbuf.st_dev ||
2346 tmpstatbuf.st_ino != PL_statbuf.st_ino) {
2347 (void)PerlIO_close(PL_rsfp);
2348 if (PL_rsfp = PerlProc_popen("/bin/mail root","w")) { /* heh, heh */
2349 PerlIO_printf(PL_rsfp,
2350 "User %ld tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
2351 (Filename of set-id script was %s, uid %ld gid %ld.)\n\nSincerely,\nperl\n",
2352 (long)PL_uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
2353 (long)PL_statbuf.st_dev, (long)PL_statbuf.st_ino,
2354 SvPVX(GvSV(PL_curcop->cop_filegv)),
2355 (long)PL_statbuf.st_uid, (long)PL_statbuf.st_gid);
2356 (void)PerlProc_pclose(PL_rsfp);
2358 Perl_croak(aTHX_ "Permission denied\n");
2362 setreuid(PL_uid,PL_euid) < 0
2364 # if defined(HAS_SETRESUID)
2365 setresuid(PL_uid,PL_euid,(Uid_t)-1) < 0
2368 || PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid)
2369 Perl_croak(aTHX_ "Can't reswap uid and euid");
2370 if (!cando(S_IXUSR,FALSE,&PL_statbuf)) /* can real uid exec? */
2371 Perl_croak(aTHX_ "Permission denied\n");
2373 #endif /* HAS_SETREUID */
2374 #endif /* IAMSUID */
2376 if (!S_ISREG(PL_statbuf.st_mode))
2377 Perl_croak(aTHX_ "Permission denied");
2378 if (PL_statbuf.st_mode & S_IWOTH)
2379 Perl_croak(aTHX_ "Setuid/gid script is writable by world");
2380 PL_doswitches = FALSE; /* -s is insecure in suid */
2381 PL_curcop->cop_line++;
2382 if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch ||
2383 strnNE(SvPV(PL_linestr,n_a),"#!",2) ) /* required even on Sys V */
2384 Perl_croak(aTHX_ "No #! line");
2385 s = SvPV(PL_linestr,n_a)+2;
2387 while (!isSPACE(*s)) s++;
2388 for (s2 = s; (s2 > SvPV(PL_linestr,n_a)+2 &&
2389 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
2390 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
2391 Perl_croak(aTHX_ "Not a perl script");
2392 while (*s == ' ' || *s == '\t') s++;
2394 * #! arg must be what we saw above. They can invoke it by
2395 * mentioning suidperl explicitly, but they may not add any strange
2396 * arguments beyond what #! says if they do invoke suidperl that way.
2398 len = strlen(validarg);
2399 if (strEQ(validarg," PHOOEY ") ||
2400 strnNE(s,validarg,len) || !isSPACE(s[len]))
2401 Perl_croak(aTHX_ "Args must match #! line");
2404 if (PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
2405 PL_euid == PL_statbuf.st_uid)
2407 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2408 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2409 #endif /* IAMSUID */
2411 if (PL_euid) { /* oops, we're not the setuid root perl */
2412 (void)PerlIO_close(PL_rsfp);
2415 PerlProc_execv(Perl_form(aTHX_ "%s/sperl%s", BIN_EXP, PL_patchlevel), PL_origargv);
2417 Perl_croak(aTHX_ "Can't do setuid\n");
2420 if (PL_statbuf.st_mode & S_ISGID && PL_statbuf.st_gid != PL_egid) {
2422 (void)setegid(PL_statbuf.st_gid);
2425 (void)setregid((Gid_t)-1,PL_statbuf.st_gid);
2427 #ifdef HAS_SETRESGID
2428 (void)setresgid((Gid_t)-1,PL_statbuf.st_gid,(Gid_t)-1);
2430 PerlProc_setgid(PL_statbuf.st_gid);
2434 if (PerlProc_getegid() != PL_statbuf.st_gid)
2435 Perl_croak(aTHX_ "Can't do setegid!\n");
2437 if (PL_statbuf.st_mode & S_ISUID) {
2438 if (PL_statbuf.st_uid != PL_euid)
2440 (void)seteuid(PL_statbuf.st_uid); /* all that for this */
2443 (void)setreuid((Uid_t)-1,PL_statbuf.st_uid);
2445 #ifdef HAS_SETRESUID
2446 (void)setresuid((Uid_t)-1,PL_statbuf.st_uid,(Uid_t)-1);
2448 PerlProc_setuid(PL_statbuf.st_uid);
2452 if (PerlProc_geteuid() != PL_statbuf.st_uid)
2453 Perl_croak(aTHX_ "Can't do seteuid!\n");
2455 else if (PL_uid) { /* oops, mustn't run as root */
2457 (void)seteuid((Uid_t)PL_uid);
2460 (void)setreuid((Uid_t)-1,(Uid_t)PL_uid);
2462 #ifdef HAS_SETRESUID
2463 (void)setresuid((Uid_t)-1,(Uid_t)PL_uid,(Uid_t)-1);
2465 PerlProc_setuid((Uid_t)PL_uid);
2469 if (PerlProc_geteuid() != PL_uid)
2470 Perl_croak(aTHX_ "Can't do seteuid!\n");
2473 if (!cando(S_IXUSR,TRUE,&PL_statbuf))
2474 Perl_croak(aTHX_ "Permission denied\n"); /* they can't do this */
2477 else if (PL_preprocess)
2478 Perl_croak(aTHX_ "-P not allowed for setuid/setgid script\n");
2479 else if (fdscript >= 0)
2480 Perl_croak(aTHX_ "fd script not allowed in suidperl\n");
2482 Perl_croak(aTHX_ "Script is not setuid/setgid in suidperl\n");
2484 /* We absolutely must clear out any saved ids here, so we */
2485 /* exec the real perl, substituting fd script for scriptname. */
2486 /* (We pass script name as "subdir" of fd, which perl will grok.) */
2487 PerlIO_rewind(PL_rsfp);
2488 PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0); /* just in case rewind didn't */
2489 for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;
2490 if (!PL_origargv[which])
2491 Perl_croak(aTHX_ "Permission denied");
2492 PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s",
2493 PerlIO_fileno(PL_rsfp), PL_origargv[which]));
2494 #if defined(HAS_FCNTL) && defined(F_SETFD)
2495 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0); /* ensure no close-on-exec */
2497 PerlProc_execv(Perl_form(aTHX_ "%s/perl%s", BIN_EXP, PL_patchlevel), PL_origargv);/* try again */
2498 Perl_croak(aTHX_ "Can't do setuid\n");
2499 #endif /* IAMSUID */
2501 if (PL_euid != PL_uid || PL_egid != PL_gid) { /* (suidperl doesn't exist, in fact) */
2502 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
2504 PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf); /* may be either wrapped or real suid */
2505 if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
2507 (PL_egid != PL_gid && PL_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
2510 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2511 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2512 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
2513 /* not set-id, must be wrapped */
2519 S_find_beginning(pTHX)
2521 register char *s, *s2;
2523 /* skip forward in input to the real script? */
2526 while (PL_doextract) {
2527 if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch)
2528 Perl_croak(aTHX_ "No Perl script found in input\n");
2529 if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
2530 PerlIO_ungetc(PL_rsfp, '\n'); /* to keep line count right */
2531 PL_doextract = FALSE;
2532 while (*s && !(isSPACE (*s) || *s == '#')) s++;
2534 while (*s == ' ' || *s == '\t') s++;
2536 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2537 if (strnEQ(s2-4,"perl",4))
2539 while (s = moreswitches(s)) ;
2549 PL_uid = PerlProc_getuid();
2550 PL_euid = PerlProc_geteuid();
2551 PL_gid = PerlProc_getgid();
2552 PL_egid = PerlProc_getegid();
2554 PL_uid |= PL_gid << 16;
2555 PL_euid |= PL_egid << 16;
2557 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2561 S_forbid_setid(pTHX_ char *s)
2563 if (PL_euid != PL_uid)
2564 Perl_croak(aTHX_ "No %s allowed while running setuid", s);
2565 if (PL_egid != PL_gid)
2566 Perl_croak(aTHX_ "No %s allowed while running setgid", s);
2570 Perl_init_debugger(pTHX)
2573 HV *ostash = PL_curstash;
2575 PL_curstash = PL_debstash;
2576 PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2577 AvREAL_off(PL_dbargs);
2578 PL_DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2579 PL_DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2580 PL_DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2581 sv_upgrade(GvSV(PL_DBsub), SVt_IV); /* IVX accessed if PERLDB_SUB_NN */
2582 PL_DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2583 sv_setiv(PL_DBsingle, 0);
2584 PL_DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2585 sv_setiv(PL_DBtrace, 0);
2586 PL_DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2587 sv_setiv(PL_DBsignal, 0);
2588 PL_curstash = ostash;
2591 #ifndef STRESS_REALLOC
2592 #define REASONABLE(size) (size)
2594 #define REASONABLE(size) (1) /* unreasonable */
2598 Perl_init_stacks(pTHX)
2600 /* start with 128-item stack and 8K cxstack */
2601 PL_curstackinfo = new_stackinfo(REASONABLE(128),
2602 REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
2603 PL_curstackinfo->si_type = PERLSI_MAIN;
2604 PL_curstack = PL_curstackinfo->si_stack;
2605 PL_mainstack = PL_curstack; /* remember in case we switch stacks */
2607 PL_stack_base = AvARRAY(PL_curstack);
2608 PL_stack_sp = PL_stack_base;
2609 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
2611 New(50,PL_tmps_stack,REASONABLE(128),SV*);
2614 PL_tmps_max = REASONABLE(128);
2616 New(54,PL_markstack,REASONABLE(32),I32);
2617 PL_markstack_ptr = PL_markstack;
2618 PL_markstack_max = PL_markstack + REASONABLE(32);
2622 New(54,PL_scopestack,REASONABLE(32),I32);
2623 PL_scopestack_ix = 0;
2624 PL_scopestack_max = REASONABLE(32);
2626 New(54,PL_savestack,REASONABLE(128),ANY);
2627 PL_savestack_ix = 0;
2628 PL_savestack_max = REASONABLE(128);
2630 New(54,PL_retstack,REASONABLE(16),OP*);
2632 PL_retstack_max = REASONABLE(16);
2641 while (PL_curstackinfo->si_next)
2642 PL_curstackinfo = PL_curstackinfo->si_next;
2643 while (PL_curstackinfo) {
2644 PERL_SI *p = PL_curstackinfo->si_prev;
2645 /* curstackinfo->si_stack got nuked by sv_free_arenas() */
2646 Safefree(PL_curstackinfo->si_cxstack);
2647 Safefree(PL_curstackinfo);
2648 PL_curstackinfo = p;
2650 Safefree(PL_tmps_stack);
2651 Safefree(PL_markstack);
2652 Safefree(PL_scopestack);
2653 Safefree(PL_savestack);
2654 Safefree(PL_retstack);
2658 static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
2669 lex_start(PL_linestr);
2671 PL_subname = newSVpvn("main",4);
2675 S_init_predump_symbols(pTHX)
2682 sv_setpvn(get_sv("\"", TRUE), " ", 1);
2683 PL_stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2684 GvMULTI_on(PL_stdingv);
2685 io = GvIOp(PL_stdingv);
2686 IoIFP(io) = PerlIO_stdin();
2687 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2689 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
2691 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2694 IoOFP(io) = IoIFP(io) = PerlIO_stdout();
2696 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2698 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
2700 PL_stderrgv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2701 GvMULTI_on(PL_stderrgv);
2702 io = GvIOp(PL_stderrgv);
2703 IoOFP(io) = IoIFP(io) = PerlIO_stderr();
2704 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2706 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
2708 PL_statname = NEWSV(66,0); /* last filename we did stat on */
2711 PL_osname = savepv(OSNAME);
2715 S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
2722 argc--,argv++; /* skip name of script */
2723 if (PL_doswitches) {
2724 for (; argc > 0 && **argv == '-'; argc--,argv++) {
2727 if (argv[0][1] == '-') {
2731 if (s = strchr(argv[0], '=')) {
2733 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2736 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2739 PL_toptarget = NEWSV(0,0);
2740 sv_upgrade(PL_toptarget, SVt_PVFM);
2741 sv_setpvn(PL_toptarget, "", 0);
2742 PL_bodytarget = NEWSV(0,0);
2743 sv_upgrade(PL_bodytarget, SVt_PVFM);
2744 sv_setpvn(PL_bodytarget, "", 0);
2745 PL_formtarget = PL_bodytarget;
2748 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2749 sv_setpv(GvSV(tmpgv),PL_origfilename);
2750 magicname("0", "0", 1);
2752 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2754 sv_setpv(GvSV(tmpgv), os2_execname());
2756 sv_setpv(GvSV(tmpgv),PL_origargv[0]);
2758 if (PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2759 GvMULTI_on(PL_argvgv);
2760 (void)gv_AVadd(PL_argvgv);
2761 av_clear(GvAVn(PL_argvgv));
2762 for (; argc > 0; argc--,argv++) {
2763 av_push(GvAVn(PL_argvgv),newSVpv(argv[0],0));
2766 if (PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2768 GvMULTI_on(PL_envgv);
2769 hv = GvHVn(PL_envgv);
2770 hv_magic(hv, PL_envgv, 'E');
2771 #if !defined( VMS) && !defined(EPOC) /* VMS doesn't have environ array */
2772 /* Note that if the supplied env parameter is actually a copy
2773 of the global environ then it may now point to free'd memory
2774 if the environment has been modified since. To avoid this
2775 problem we treat env==NULL as meaning 'use the default'
2780 environ[0] = Nullch;
2781 for (; *env; env++) {
2782 if (!(s = strchr(*env,'=')))
2788 sv = newSVpv(s--,0);
2789 (void)hv_store(hv, *env, s - *env, sv, 0);
2791 #if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV)
2792 /* Sins of the RTL. See note in my_setenv(). */
2793 (void)PerlEnv_putenv(savepv(*env));
2797 #ifdef DYNAMIC_ENV_FETCH
2798 HvNAME(hv) = savepv(ENV_HV_NAME);
2802 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2803 sv_setiv(GvSV(tmpgv), (IV)getpid());
2807 S_init_perllib(pTHX)
2812 s = PerlEnv_getenv("PERL5LIB");
2816 incpush(PerlEnv_getenv("PERLLIB"), FALSE);
2818 /* Treat PERL5?LIB as a possible search list logical name -- the
2819 * "natural" VMS idiom for a Unix path string. We allow each
2820 * element to be a set of |-separated directories for compatibility.
2824 if (my_trnlnm("PERL5LIB",buf,0))
2825 do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
2827 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
2831 /* Use the ~-expanded versions of APPLLIB (undocumented),
2832 ARCHLIB PRIVLIB SITEARCH and SITELIB
2835 incpush(APPLLIB_EXP, TRUE);
2839 incpush(ARCHLIB_EXP, FALSE);
2842 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2845 incpush(PRIVLIB_EXP, TRUE);
2847 incpush(PRIVLIB_EXP, FALSE);
2851 incpush(SITEARCH_EXP, FALSE);
2855 incpush(SITELIB_EXP, TRUE);
2857 incpush(SITELIB_EXP, FALSE);
2860 #if defined(PERL_VENDORLIB_EXP)
2862 incpush(PERL_VENDORLIB_EXP, TRUE);
2864 incpush(PERL_VENDORLIB_EXP, FALSE);
2868 incpush(".", FALSE);
2872 # define PERLLIB_SEP ';'
2875 # define PERLLIB_SEP '|'
2877 # define PERLLIB_SEP ':'
2880 #ifndef PERLLIB_MANGLE
2881 # define PERLLIB_MANGLE(s,n) (s)
2885 S_incpush(pTHX_ char *p, int addsubdirs)
2887 SV *subdir = Nullsv;
2893 subdir = sv_newmortal();
2894 if (!PL_archpat_auto) {
2895 STRLEN len = (sizeof(ARCHNAME) + strlen(PL_patchlevel)
2896 + sizeof("//auto"));
2897 New(55, PL_archpat_auto, len, char);
2898 sprintf(PL_archpat_auto, "/%s/%s/auto", ARCHNAME, PL_patchlevel);
2900 for (len = sizeof(ARCHNAME) + 2;
2901 PL_archpat_auto[len] != '\0' && PL_archpat_auto[len] != '/'; len++)
2902 if (PL_archpat_auto[len] == '.') PL_archpat_auto[len] = '_';
2907 /* Break at all separators */
2909 SV *libdir = NEWSV(55,0);
2912 /* skip any consecutive separators */
2913 while ( *p == PERLLIB_SEP ) {
2914 /* Uncomment the next line for PATH semantics */
2915 /* av_push(GvAVn(PL_incgv), newSVpvn(".", 1)); */
2919 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
2920 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
2925 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
2926 p = Nullch; /* break out */
2930 * BEFORE pushing libdir onto @INC we may first push version- and
2931 * archname-specific sub-directories.
2934 struct stat tmpstatbuf;
2939 if ((unix = tounixspec_ts(SvPV(libdir,len),Nullch)) != Nullch) {
2941 while (unix[len-1] == '/') len--; /* Cosmetic */
2942 sv_usepvn(libdir,unix,len);
2945 PerlIO_printf(Perl_error_log,
2946 "Failed to unixify @INC element \"%s\"\n",
2949 /* .../archname/version if -d .../archname/version/auto */
2950 sv_setsv(subdir, libdir);
2951 sv_catpv(subdir, PL_archpat_auto);
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"));
2957 /* .../archname if -d .../archname/auto */
2958 sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
2959 strlen(PL_patchlevel) + 1, "", 0);
2960 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2961 S_ISDIR(tmpstatbuf.st_mode))
2962 av_push(GvAVn(PL_incgv),
2963 newSVpvn(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2966 /* finally push this lib directory on the end of @INC */
2967 av_push(GvAVn(PL_incgv), libdir);
2972 STATIC struct perl_thread *
2973 S_init_main_thread(pTHX)
2975 #if !defined(PERL_IMPLICIT_CONTEXT)
2976 struct perl_thread *thr;
2980 Newz(53, thr, 1, struct perl_thread);
2981 PL_curcop = &PL_compiling;
2982 thr->interp = PERL_GET_INTERP;
2983 thr->cvcache = newHV();
2984 thr->threadsv = newAV();
2985 /* thr->threadsvp is set when find_threadsv is called */
2986 thr->specific = newAV();
2987 thr->flags = THRf_R_JOINABLE;
2988 MUTEX_INIT(&thr->mutex);
2989 /* Handcraft thrsv similarly to mess_sv */
2990 New(53, PL_thrsv, 1, SV);
2991 Newz(53, xpv, 1, XPV);
2992 SvFLAGS(PL_thrsv) = SVt_PV;
2993 SvANY(PL_thrsv) = (void*)xpv;
2994 SvREFCNT(PL_thrsv) = 1 << 30; /* practically infinite */
2995 SvPVX(PL_thrsv) = (char*)thr;
2996 SvCUR_set(PL_thrsv, sizeof(thr));
2997 SvLEN_set(PL_thrsv, sizeof(thr));
2998 *SvEND(PL_thrsv) = '\0'; /* in the trailing_nul field */
2999 thr->oursv = PL_thrsv;
3000 PL_chopset = " \n-";
3003 MUTEX_LOCK(&PL_threads_mutex);
3008 MUTEX_UNLOCK(&PL_threads_mutex);
3010 #ifdef HAVE_THREAD_INTERN
3011 Perl_init_thread_intern(thr);
3014 #ifdef SET_THREAD_SELF
3015 SET_THREAD_SELF(thr);
3017 thr->self = pthread_self();
3018 #endif /* SET_THREAD_SELF */
3022 * These must come after the SET_THR because sv_setpvn does
3023 * SvTAINT and the taint fields require dTHR.
3025 PL_toptarget = NEWSV(0,0);
3026 sv_upgrade(PL_toptarget, SVt_PVFM);
3027 sv_setpvn(PL_toptarget, "", 0);
3028 PL_bodytarget = NEWSV(0,0);
3029 sv_upgrade(PL_bodytarget, SVt_PVFM);
3030 sv_setpvn(PL_bodytarget, "", 0);
3031 PL_formtarget = PL_bodytarget;
3032 thr->errsv = newSVpvn("", 0);
3033 (void) find_threadsv("@"); /* Ensure $@ is initialised early */
3036 PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp);
3037 PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags);
3038 PL_regint_start = MEMBER_TO_FPTR(Perl_re_intuit_start);
3039 PL_regint_string = MEMBER_TO_FPTR(Perl_re_intuit_string);
3040 PL_regfree = MEMBER_TO_FPTR(Perl_pregfree);
3042 PL_reginterp_cnt = 0;
3046 #endif /* USE_THREADS */
3049 Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
3053 line_t oldline = PL_curcop->cop_line;
3059 while (AvFILL(paramList) >= 0) {
3060 cv = (CV*)av_shift(paramList);
3062 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_call_list_body), cv);
3065 (void)SvPV(atsv, len);
3067 PL_curcop = &PL_compiling;
3068 PL_curcop->cop_line = oldline;
3069 if (paramList == PL_beginav)
3070 sv_catpv(atsv, "BEGIN failed--compilation aborted");
3072 sv_catpv(atsv, "END failed--cleanup aborted");
3073 while (PL_scopestack_ix > oldscope)
3075 Perl_croak(aTHX_ "%s", SvPVX(atsv));
3082 /* my_exit() was called */
3083 while (PL_scopestack_ix > oldscope)
3086 PL_curstash = PL_defstash;
3087 if (PL_endav && !PL_minus_c)
3088 call_list(oldscope, PL_endav);
3089 PL_curcop = &PL_compiling;
3090 PL_curcop->cop_line = oldline;
3091 if (PL_statusvalue) {
3092 if (paramList == PL_beginav)
3093 Perl_croak(aTHX_ "BEGIN failed--compilation aborted");
3095 Perl_croak(aTHX_ "END failed--cleanup aborted");
3101 PL_curcop = &PL_compiling;
3102 PL_curcop->cop_line = oldline;
3105 PerlIO_printf(Perl_error_log, "panic: restartop\n");
3113 S_call_list_body(pTHX_ va_list args)
3116 CV *cv = va_arg(args, CV*);
3118 PUSHMARK(PL_stack_sp);
3119 call_sv((SV*)cv, G_EVAL|G_DISCARD);
3124 Perl_my_exit(pTHX_ U32 status)
3128 DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
3129 thr, (unsigned long) status));
3138 STATUS_NATIVE_SET(status);
3145 Perl_my_failure_exit(pTHX)
3148 if (vaxc$errno & 1) {
3149 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
3150 STATUS_NATIVE_SET(44);
3153 if (!vaxc$errno && errno) /* unlikely */
3154 STATUS_NATIVE_SET(44);
3156 STATUS_NATIVE_SET(vaxc$errno);
3161 STATUS_POSIX_SET(errno);
3163 exitstatus = STATUS_POSIX >> 8;
3164 if (exitstatus & 255)
3165 STATUS_POSIX_SET(exitstatus);
3167 STATUS_POSIX_SET(255);
3174 S_my_exit_jump(pTHX)
3177 register PERL_CONTEXT *cx;
3182 SvREFCNT_dec(PL_e_script);
3183 PL_e_script = Nullsv;
3186 POPSTACK_TO(PL_mainstack);
3187 if (cxstack_ix >= 0) {
3190 POPBLOCK(cx,PL_curpm);
3203 read_e_script(pTHXo_ int idx, SV *buf_sv, int maxlen)
3206 p = SvPVX(PL_e_script);
3207 nl = strchr(p, '\n');
3208 nl = (nl) ? nl+1 : SvEND(PL_e_script);
3210 filter_del(read_e_script);
3213 sv_catpvn(buf_sv, p, nl-p);
3214 sv_chop(PL_e_script, nl);