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
50 #define perl_construct Perl_construct
51 #define perl_parse Perl_parse
52 #define perl_run Perl_run
53 #define perl_destruct Perl_destruct
54 #define perl_free Perl_free
57 #ifdef PERL_IMPLICIT_SYS
59 perl_alloc_using(struct IPerlMem* ipM, struct IPerlMem* ipMS,
60 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
61 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
62 struct IPerlDir* ipD, struct IPerlSock* ipS,
63 struct IPerlProc* ipP)
65 PerlInterpreter *my_perl;
67 my_perl = (PerlInterpreter*)new(ipM) CPerlObj(ipM, ipMS, ipMP, ipE, ipStd,
68 ipLIO, ipD, ipS, ipP);
69 PERL_SET_INTERP(my_perl);
71 /* New() needs interpreter, so call malloc() instead */
72 my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
73 PERL_SET_INTERP(my_perl);
74 Zero(my_perl, 1, PerlInterpreter);
92 PerlInterpreter *my_perl;
94 /* New() needs interpreter, so call malloc() instead */
95 my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
96 PERL_SET_INTERP(my_perl);
97 Zero(my_perl, 1, PerlInterpreter);
100 #endif /* PERL_IMPLICIT_SYS */
103 perl_construct(pTHXx)
108 struct perl_thread *thr = NULL;
109 #endif /* FAKE_THREADS */
110 #endif /* USE_THREADS */
114 PL_perl_destruct_level = 1;
116 if (PL_perl_destruct_level > 0)
120 /* Init the real globals (and main thread)? */
124 #ifdef ALLOC_THREAD_KEY
127 if (pthread_key_create(&PL_thr_key, 0))
128 Perl_croak(aTHX_ "panic: pthread_key_create");
130 MUTEX_INIT(&PL_sv_mutex);
132 * Safe to use basic SV functions from now on (though
133 * not things like mortals or tainting yet).
135 MUTEX_INIT(&PL_eval_mutex);
136 COND_INIT(&PL_eval_cond);
137 MUTEX_INIT(&PL_threads_mutex);
138 COND_INIT(&PL_nthreads_cond);
139 #ifdef EMULATE_ATOMIC_REFCOUNTS
140 MUTEX_INIT(&PL_svref_mutex);
141 #endif /* EMULATE_ATOMIC_REFCOUNTS */
143 MUTEX_INIT(&PL_cred_mutex);
145 thr = init_main_thread();
146 #endif /* USE_THREADS */
148 PL_protect = MEMBER_TO_FPTR(Perl_default_protect); /* for exceptions */
150 PL_curcop = &PL_compiling; /* needed by ckWARN, right away */
152 PL_linestr = NEWSV(65,79);
153 sv_upgrade(PL_linestr,SVt_PVIV);
155 if (!SvREADONLY(&PL_sv_undef)) {
156 /* set read-only and try to insure than we wont see REFCNT==0
159 SvREADONLY_on(&PL_sv_undef);
160 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
162 sv_setpv(&PL_sv_no,PL_No);
164 SvREADONLY_on(&PL_sv_no);
165 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
167 sv_setpv(&PL_sv_yes,PL_Yes);
169 SvREADONLY_on(&PL_sv_yes);
170 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
175 /* PL_sighandlerp = sighandler; */
177 PL_sighandlerp = Perl_sighandler;
179 PL_pidstatus = newHV();
183 * There is no way we can refer to them from Perl so close them to save
184 * space. The other alternative would be to provide STDAUX and STDPRN
187 (void)fclose(stdaux);
188 (void)fclose(stdprn);
192 PL_nrs = newSVpvn("\n", 1);
193 PL_rs = SvREFCNT_inc(PL_nrs);
198 PL_lex_state = LEX_NOTPARSING;
204 SET_NUMERIC_STANDARD();
208 PL_patchlevel = NEWSV(0,4);
209 SvUPGRADE(PL_patchlevel, SVt_PVNV);
210 if (PERL_REVISION > 127 || PERL_VERSION > 127 || PERL_SUBVERSION > 127)
211 SvGROW(PL_patchlevel,24);
212 s = (U8*)SvPVX(PL_patchlevel);
213 s = uv_to_utf8(s, (UV)PERL_REVISION);
214 s = uv_to_utf8(s, (UV)PERL_VERSION);
215 s = uv_to_utf8(s, (UV)PERL_SUBVERSION);
217 SvCUR_set(PL_patchlevel, s - (U8*)SvPVX(PL_patchlevel));
218 SvPOK_on(PL_patchlevel);
219 SvNVX(PL_patchlevel) = (NV)PERL_REVISION
220 + ((NV)PERL_VERSION / (NV)1000)
221 #if defined(PERL_SUBVERSION) && PERL_SUBVERSION > 0
222 + ((NV)PERL_SUBVERSION / (NV)1000000)
225 SvNOK_on(PL_patchlevel); /* dual valued */
226 SvUTF8_on(PL_patchlevel);
227 SvREADONLY_on(PL_patchlevel);
230 #if defined(LOCAL_PATCH_COUNT)
231 PL_localpatches = local_patches; /* For possible -v */
234 PerlIO_init(); /* Hook to IO system */
236 PL_fdpid = newAV(); /* for remembering popen pids by fd */
237 PL_modglobal = newHV(); /* pointers to per-interpreter module globals */
246 int destruct_level; /* 0=none, 1=full, 2=full with checks */
252 #endif /* USE_THREADS */
254 /* wait for all pseudo-forked children to finish */
255 PERL_WAIT_FOR_CHILDREN;
259 /* Pass 1 on any remaining threads: detach joinables, join zombies */
261 MUTEX_LOCK(&PL_threads_mutex);
262 DEBUG_S(PerlIO_printf(Perl_debug_log,
263 "perl_destruct: waiting for %d threads...\n",
265 for (t = thr->next; t != thr; t = t->next) {
266 MUTEX_LOCK(&t->mutex);
267 switch (ThrSTATE(t)) {
270 DEBUG_S(PerlIO_printf(Perl_debug_log,
271 "perl_destruct: joining zombie %p\n", t));
272 ThrSETSTATE(t, THRf_DEAD);
273 MUTEX_UNLOCK(&t->mutex);
276 * The SvREFCNT_dec below may take a long time (e.g. av
277 * may contain an object scalar whose destructor gets
278 * called) so we have to unlock threads_mutex and start
281 MUTEX_UNLOCK(&PL_threads_mutex);
283 SvREFCNT_dec((SV*)av);
284 DEBUG_S(PerlIO_printf(Perl_debug_log,
285 "perl_destruct: joined zombie %p OK\n", t));
287 case THRf_R_JOINABLE:
288 DEBUG_S(PerlIO_printf(Perl_debug_log,
289 "perl_destruct: detaching thread %p\n", t));
290 ThrSETSTATE(t, THRf_R_DETACHED);
292 * We unlock threads_mutex and t->mutex in the opposite order
293 * from which we locked them just so that DETACH won't
294 * deadlock if it panics. It's only a breach of good style
295 * not a bug since they are unlocks not locks.
297 MUTEX_UNLOCK(&PL_threads_mutex);
299 MUTEX_UNLOCK(&t->mutex);
302 DEBUG_S(PerlIO_printf(Perl_debug_log,
303 "perl_destruct: ignoring %p (state %u)\n",
305 MUTEX_UNLOCK(&t->mutex);
306 /* fall through and out */
309 /* We leave the above "Pass 1" loop with threads_mutex still locked */
311 /* Pass 2 on remaining threads: wait for the thread count to drop to one */
312 while (PL_nthreads > 1)
314 DEBUG_S(PerlIO_printf(Perl_debug_log,
315 "perl_destruct: final wait for %d threads\n",
317 COND_WAIT(&PL_nthreads_cond, &PL_threads_mutex);
319 /* At this point, we're the last thread */
320 MUTEX_UNLOCK(&PL_threads_mutex);
321 DEBUG_S(PerlIO_printf(Perl_debug_log, "perl_destruct: armageddon has arrived\n"));
322 MUTEX_DESTROY(&PL_threads_mutex);
323 COND_DESTROY(&PL_nthreads_cond);
324 #endif /* !defined(FAKE_THREADS) */
325 #endif /* USE_THREADS */
327 destruct_level = PL_perl_destruct_level;
331 if (s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL")) {
333 if (destruct_level < i)
342 /* We must account for everything. */
344 /* Destroy the main CV and syntax tree */
346 PL_curpad = AvARRAY(PL_comppad);
347 op_free(PL_main_root);
348 PL_main_root = Nullop;
350 PL_curcop = &PL_compiling;
351 PL_main_start = Nullop;
352 SvREFCNT_dec(PL_main_cv);
356 if (PL_sv_objcount) {
358 * Try to destruct global references. We do this first so that the
359 * destructors and destructees still exist. Some sv's might remain.
360 * Non-referenced objects are on their own.
365 /* unhook hooks which will soon be, or use, destroyed data */
366 SvREFCNT_dec(PL_warnhook);
367 PL_warnhook = Nullsv;
368 SvREFCNT_dec(PL_diehook);
371 /* call exit list functions */
372 while (PL_exitlistlen-- > 0)
373 PL_exitlist[PL_exitlistlen].fn(aTHXo_ PL_exitlist[PL_exitlistlen].ptr);
375 Safefree(PL_exitlist);
377 if (destruct_level == 0){
379 DEBUG_P(debprofdump());
381 /* The exit() function will do everything that needs doing. */
385 /* loosen bonds of global variables */
388 (void)PerlIO_close(PL_rsfp);
392 /* Filters for program text */
393 SvREFCNT_dec(PL_rsfp_filters);
394 PL_rsfp_filters = Nullav;
397 PL_preprocess = FALSE;
403 PL_doswitches = FALSE;
404 PL_dowarn = G_WARN_OFF;
405 PL_doextract = FALSE;
406 PL_sawampersand = FALSE; /* must save all match strings */
409 Safefree(PL_inplace);
411 SvREFCNT_dec(PL_patchlevel);
414 SvREFCNT_dec(PL_e_script);
415 PL_e_script = Nullsv;
418 /* magical thingies */
420 Safefree(PL_ofs); /* $, */
423 Safefree(PL_ors); /* $\ */
426 SvREFCNT_dec(PL_rs); /* $/ */
429 SvREFCNT_dec(PL_nrs); /* $/ helper */
432 PL_multiline = 0; /* $* */
434 SvREFCNT_dec(PL_statname);
435 PL_statname = Nullsv;
438 /* defgv, aka *_ should be taken care of elsewhere */
440 /* clean up after study() */
441 SvREFCNT_dec(PL_lastscream);
442 PL_lastscream = Nullsv;
443 Safefree(PL_screamfirst);
445 Safefree(PL_screamnext);
449 Safefree(PL_efloatbuf);
450 PL_efloatbuf = Nullch;
453 /* startup and shutdown function lists */
454 SvREFCNT_dec(PL_beginav);
455 SvREFCNT_dec(PL_endav);
456 SvREFCNT_dec(PL_stopav);
457 SvREFCNT_dec(PL_initav);
463 /* shortcuts just get cleared */
469 PL_argvoutgv = Nullgv;
471 PL_stderrgv = Nullgv;
472 PL_last_in_gv = Nullgv;
474 PL_debstash = Nullhv;
476 /* reset so print() ends up where we expect */
479 SvREFCNT_dec(PL_argvout_stack);
480 PL_argvout_stack = Nullav;
482 SvREFCNT_dec(PL_fdpid);
484 SvREFCNT_dec(PL_modglobal);
485 PL_modglobal = Nullhv;
486 SvREFCNT_dec(PL_preambleav);
487 PL_preambleav = Nullav;
488 SvREFCNT_dec(PL_subname);
490 SvREFCNT_dec(PL_linestr);
492 SvREFCNT_dec(PL_pidstatus);
493 PL_pidstatus = Nullhv;
494 SvREFCNT_dec(PL_toptarget);
495 PL_toptarget = Nullsv;
496 SvREFCNT_dec(PL_bodytarget);
497 PL_bodytarget = Nullsv;
498 PL_formtarget = Nullsv;
500 /* clear utf8 character classes */
501 SvREFCNT_dec(PL_utf8_alnum);
502 SvREFCNT_dec(PL_utf8_alnumc);
503 SvREFCNT_dec(PL_utf8_ascii);
504 SvREFCNT_dec(PL_utf8_alpha);
505 SvREFCNT_dec(PL_utf8_space);
506 SvREFCNT_dec(PL_utf8_cntrl);
507 SvREFCNT_dec(PL_utf8_graph);
508 SvREFCNT_dec(PL_utf8_digit);
509 SvREFCNT_dec(PL_utf8_upper);
510 SvREFCNT_dec(PL_utf8_lower);
511 SvREFCNT_dec(PL_utf8_print);
512 SvREFCNT_dec(PL_utf8_punct);
513 SvREFCNT_dec(PL_utf8_xdigit);
514 SvREFCNT_dec(PL_utf8_mark);
515 SvREFCNT_dec(PL_utf8_toupper);
516 SvREFCNT_dec(PL_utf8_tolower);
517 PL_utf8_alnum = Nullsv;
518 PL_utf8_alnumc = Nullsv;
519 PL_utf8_ascii = Nullsv;
520 PL_utf8_alpha = Nullsv;
521 PL_utf8_space = Nullsv;
522 PL_utf8_cntrl = Nullsv;
523 PL_utf8_graph = Nullsv;
524 PL_utf8_digit = Nullsv;
525 PL_utf8_upper = Nullsv;
526 PL_utf8_lower = Nullsv;
527 PL_utf8_print = Nullsv;
528 PL_utf8_punct = Nullsv;
529 PL_utf8_xdigit = Nullsv;
530 PL_utf8_mark = Nullsv;
531 PL_utf8_toupper = Nullsv;
532 PL_utf8_totitle = Nullsv;
533 PL_utf8_tolower = Nullsv;
535 if (!specialWARN(PL_compiling.cop_warnings))
536 SvREFCNT_dec(PL_compiling.cop_warnings);
537 PL_compiling.cop_warnings = Nullsv;
539 /* Prepare to destruct main symbol table. */
544 SvREFCNT_dec(PL_curstname);
545 PL_curstname = Nullsv;
547 /* clear queued errors */
548 SvREFCNT_dec(PL_errors);
552 if (destruct_level >= 2 && ckWARN_d(WARN_INTERNAL)) {
553 if (PL_scopestack_ix != 0)
554 Perl_warner(aTHX_ WARN_INTERNAL,
555 "Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
556 (long)PL_scopestack_ix);
557 if (PL_savestack_ix != 0)
558 Perl_warner(aTHX_ WARN_INTERNAL,
559 "Unbalanced saves: %ld more saves than restores\n",
560 (long)PL_savestack_ix);
561 if (PL_tmps_floor != -1)
562 Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced tmps: %ld more allocs than frees\n",
563 (long)PL_tmps_floor + 1);
564 if (cxstack_ix != -1)
565 Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced context: %ld more PUSHes than POPs\n",
566 (long)cxstack_ix + 1);
569 /* Now absolutely destruct everything, somehow or other, loops or no. */
571 SvFLAGS(PL_strtab) |= SVTYPEMASK; /* don't clean out strtab now */
572 while (PL_sv_count != 0 && PL_sv_count != last_sv_count) {
573 last_sv_count = PL_sv_count;
576 SvFLAGS(PL_strtab) &= ~SVTYPEMASK;
577 SvFLAGS(PL_strtab) |= SVt_PVHV;
579 /* Destruct the global string table. */
581 /* Yell and reset the HeVAL() slots that are still holding refcounts,
582 * so that sv_free() won't fail on them.
590 max = HvMAX(PL_strtab);
591 array = HvARRAY(PL_strtab);
594 if (hent && ckWARN_d(WARN_INTERNAL)) {
595 Perl_warner(aTHX_ WARN_INTERNAL,
596 "Unbalanced string table refcount: (%d) for \"%s\"",
597 HeVAL(hent) - Nullsv, HeKEY(hent));
598 HeVAL(hent) = Nullsv;
608 SvREFCNT_dec(PL_strtab);
610 if (PL_sv_count != 0 && ckWARN_d(WARN_INTERNAL))
611 Perl_warner(aTHX_ WARN_INTERNAL,"Scalars leaked: %ld\n", (long)PL_sv_count);
615 /* No SVs have survived, need to clean out */
616 Safefree(PL_origfilename);
617 Safefree(PL_reg_start_tmp);
619 Safefree(PL_reg_curpm);
620 Safefree(PL_reg_poscache);
621 Safefree(HeKEY_hek(&PL_hv_fetch_ent_mh));
622 Safefree(PL_op_mask);
624 PL_hints = 0; /* Reset hints. Should hints be per-interpreter ? */
626 DEBUG_P(debprofdump());
628 MUTEX_DESTROY(&PL_strtab_mutex);
629 MUTEX_DESTROY(&PL_sv_mutex);
630 MUTEX_DESTROY(&PL_eval_mutex);
631 MUTEX_DESTROY(&PL_cred_mutex);
632 COND_DESTROY(&PL_eval_cond);
633 #ifdef EMULATE_ATOMIC_REFCOUNTS
634 MUTEX_DESTROY(&PL_svref_mutex);
635 #endif /* EMULATE_ATOMIC_REFCOUNTS */
637 /* As the penultimate thing, free the non-arena SV for thrsv */
638 Safefree(SvPVX(PL_thrsv));
639 Safefree(SvANY(PL_thrsv));
642 #endif /* USE_THREADS */
644 /* As the absolutely last thing, free the non-arena SV for mess() */
647 /* it could have accumulated taint magic */
648 if (SvTYPE(PL_mess_sv) >= SVt_PVMG) {
651 for (mg = SvMAGIC(PL_mess_sv); mg; mg = moremagic) {
652 moremagic = mg->mg_moremagic;
653 if (mg->mg_ptr && mg->mg_type != 'g' && mg->mg_len >= 0)
654 Safefree(mg->mg_ptr);
658 /* we know that type >= SVt_PV */
659 SvOOK_off(PL_mess_sv);
660 Safefree(SvPVX(PL_mess_sv));
661 Safefree(SvANY(PL_mess_sv));
662 Safefree(PL_mess_sv);
670 #if defined(PERL_OBJECT)
678 Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr)
680 Renew(PL_exitlist, PL_exitlistlen+1, PerlExitListEntry);
681 PL_exitlist[PL_exitlistlen].fn = fn;
682 PL_exitlist[PL_exitlistlen].ptr = ptr;
687 perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env)
697 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
700 Perl_croak(aTHX_ "suidperl is no longer needed since the kernel can now execute\n\
701 setuid perl scripts securely.\n");
705 #if defined(__DYNAMIC__) && (defined(NeXT) || defined(__NeXT__))
706 _dyld_lookup_and_bind
707 ("__environ", (unsigned long *) &environ_pointer, NULL);
712 #ifndef VMS /* VMS doesn't have environ array */
713 PL_origenviron = environ;
718 /* Come here if running an undumped a.out. */
720 PL_origfilename = savepv(argv[0]);
721 PL_do_undump = FALSE;
722 cxstack_ix = -1; /* start label stack again */
724 init_postdump_symbols(argc,argv,env);
729 PL_curpad = AvARRAY(PL_comppad);
730 op_free(PL_main_root);
731 PL_main_root = Nullop;
733 PL_main_start = Nullop;
734 SvREFCNT_dec(PL_main_cv);
738 oldscope = PL_scopestack_ix;
739 PL_dowarn = G_WARN_OFF;
741 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_parse_body),
746 call_list(oldscope, PL_stopav);
752 /* my_exit() was called */
753 while (PL_scopestack_ix > oldscope)
756 PL_curstash = PL_defstash;
758 call_list(oldscope, PL_stopav);
759 return STATUS_NATIVE_EXPORT;
761 PerlIO_printf(Perl_error_log, "panic: top_env\n");
768 S_parse_body(pTHX_ va_list args)
771 int argc = PL_origargc;
772 char **argv = PL_origargv;
773 char **env = va_arg(args, char**);
774 char *scriptname = NULL;
776 VOL bool dosearch = FALSE;
781 char *cddir = Nullch;
783 XSINIT_t xsinit = va_arg(args, XSINIT_t);
785 sv_setpvn(PL_linestr,"",0);
786 sv = newSVpvn("",0); /* first used for -I flags */
790 for (argc--,argv++; argc > 0; argc--,argv++) {
791 if (argv[0][0] != '-' || !argv[0][1])
795 validarg = " PHOOEY ";
802 #ifndef PERL_STRICT_CR
826 if (s = moreswitches(s))
836 if (PL_euid != PL_uid || PL_egid != PL_gid)
837 Perl_croak(aTHX_ "No -e allowed in setuid scripts");
839 PL_e_script = newSVpvn("",0);
840 filter_add(read_e_script, NULL);
843 sv_catpv(PL_e_script, s);
845 sv_catpv(PL_e_script, argv[1]);
849 Perl_croak(aTHX_ "No code specified for -e");
850 sv_catpv(PL_e_script, "\n");
853 case 'I': /* -I handled both here and in moreswitches() */
855 if (!*++s && (s=argv[1]) != Nullch) {
860 STRLEN len = strlen(s);
863 sv_catpvn(sv, "-I", 2);
864 sv_catpvn(sv, p, len);
865 sv_catpvn(sv, " ", 1);
869 Perl_croak(aTHX_ "No directory specified for -I");
873 PL_preprocess = TRUE;
883 PL_preambleav = newAV();
884 av_push(PL_preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
886 PL_Sv = newSVpv("print myconfig();",0);
888 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
890 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
892 sv_catpv(PL_Sv,"\" Compile-time options:");
894 sv_catpv(PL_Sv," DEBUGGING");
897 sv_catpv(PL_Sv," MULTIPLICITY");
900 sv_catpv(PL_Sv," USE_THREADS");
903 sv_catpv(PL_Sv," USE_ITHREADS");
906 sv_catpv(PL_Sv," USE_64_BITS");
908 # ifdef USE_LONG_DOUBLE
909 sv_catpv(PL_Sv," USE_LONG_DOUBLE");
911 # ifdef USE_LARGE_FILES
912 sv_catpv(PL_Sv," USE_LARGE_FILES");
915 sv_catpv(PL_Sv," USE_SOCKS");
918 sv_catpv(PL_Sv," PERL_OBJECT");
920 # ifdef PERL_IMPLICIT_CONTEXT
921 sv_catpv(PL_Sv," PERL_IMPLICIT_CONTEXT");
923 # ifdef PERL_IMPLICIT_SYS
924 sv_catpv(PL_Sv," PERL_IMPLICIT_SYS");
926 sv_catpv(PL_Sv,"\\n\",");
928 #if defined(LOCAL_PATCH_COUNT)
929 if (LOCAL_PATCH_COUNT > 0) {
931 sv_catpv(PL_Sv,"\" Locally applied patches:\\n\",");
932 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
933 if (PL_localpatches[i])
934 Perl_sv_catpvf(aTHX_ PL_Sv,"q\" \t%s\n\",",PL_localpatches[i]);
938 Perl_sv_catpvf(aTHX_ PL_Sv,"\" Built under %s\\n\"",OSNAME);
941 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
943 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled on %s\\n\"",__DATE__);
948 @env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; \
949 print \" \\%ENV:\\n @env\\n\" if @env; \
950 print \" \\@INC:\\n @INC\\n\";");
953 PL_Sv = newSVpv("config_vars(qw(",0);
954 sv_catpv(PL_Sv, ++s);
955 sv_catpv(PL_Sv, "))");
958 av_push(PL_preambleav, PL_Sv);
959 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
970 if (!*++s || isSPACE(*s)) {
974 /* catch use of gnu style long options */
975 if (strEQ(s, "version")) {
979 if (strEQ(s, "help")) {
986 Perl_croak(aTHX_ "Unrecognized switch: -%s (-h will show valid options)",s);
992 #ifndef SECURE_INTERNAL_GETENV
995 (s = PerlEnv_getenv("PERL5OPT")))
999 if (*s == '-' && *(s+1) == 'T')
1012 if (!strchr("DIMUdmw", *s))
1013 Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s);
1014 s = moreswitches(s);
1020 scriptname = argv[0];
1023 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
1025 else if (scriptname == Nullch) {
1027 if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
1035 open_script(scriptname,dosearch,sv,&fdscript);
1037 validate_suid(validarg, scriptname,fdscript);
1039 #if defined(SIGCHLD) || defined(SIGCLD)
1042 # define SIGCHLD SIGCLD
1044 Sighandler_t sigstate = rsignal_state(SIGCHLD);
1045 if (sigstate == SIG_IGN) {
1046 if (ckWARN(WARN_SIGNAL))
1047 Perl_warner(aTHX_ WARN_SIGNAL,
1048 "Can't ignore signal CHLD, forcing to default");
1049 (void)rsignal(SIGCHLD, (Sighandler_t)SIG_DFL);
1056 if (cddir && PerlDir_chdir(cddir) < 0)
1057 Perl_croak(aTHX_ "Can't chdir to %s",cddir);
1061 PL_main_cv = PL_compcv = (CV*)NEWSV(1104,0);
1062 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
1063 CvUNIQUE_on(PL_compcv);
1065 PL_comppad = newAV();
1066 av_push(PL_comppad, Nullsv);
1067 PL_curpad = AvARRAY(PL_comppad);
1068 PL_comppad_name = newAV();
1069 PL_comppad_name_fill = 0;
1070 PL_min_intro_pending = 0;
1073 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
1074 PL_curpad[0] = (SV*)newAV();
1075 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
1076 CvOWNER(PL_compcv) = 0;
1077 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
1078 MUTEX_INIT(CvMUTEXP(PL_compcv));
1079 #endif /* USE_THREADS */
1081 comppadlist = newAV();
1082 AvREAL_off(comppadlist);
1083 av_store(comppadlist, 0, (SV*)PL_comppad_name);
1084 av_store(comppadlist, 1, (SV*)PL_comppad);
1085 CvPADLIST(PL_compcv) = comppadlist;
1087 boot_core_UNIVERSAL();
1088 boot_core_xsutils();
1091 (*xsinit)(aTHXo); /* in case linked C routines want magical variables */
1092 #if defined(VMS) || defined(WIN32) || defined(DJGPP)
1100 init_predump_symbols();
1101 /* init_postdump_symbols not currently designed to be called */
1102 /* more than once (ENV isn't cleared first, for example) */
1103 /* But running with -u leaves %ENV & @ARGV undefined! XXX */
1105 init_postdump_symbols(argc,argv,env);
1109 /* now parse the script */
1111 SETERRNO(0,SS$_NORMAL);
1113 if (yyparse() || PL_error_count) {
1115 Perl_croak(aTHX_ "%s had compilation errors.\n", PL_origfilename);
1117 Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
1121 CopLINE_set(PL_curcop, 0);
1122 PL_curstash = PL_defstash;
1123 PL_preprocess = FALSE;
1125 SvREFCNT_dec(PL_e_script);
1126 PL_e_script = Nullsv;
1129 /* now that script is parsed, we can modify record separator */
1130 SvREFCNT_dec(PL_rs);
1131 PL_rs = SvREFCNT_inc(PL_nrs);
1132 sv_setsv(get_sv("/", TRUE), PL_rs);
1137 SAVECOPFILE(PL_curcop);
1138 SAVECOPLINE(PL_curcop);
1139 gv_check(PL_defstash);
1146 if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
1147 dump_mstats("after compilation:");
1166 oldscope = PL_scopestack_ix;
1169 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_run_body), oldscope);
1172 cxstack_ix = -1; /* start context stack again */
1174 case 0: /* normal completion */
1175 case 2: /* my_exit() */
1176 while (PL_scopestack_ix > oldscope)
1179 PL_curstash = PL_defstash;
1180 if (PL_endav && !PL_minus_c)
1181 call_list(oldscope, PL_endav);
1183 if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
1184 dump_mstats("after execution: ");
1186 return STATUS_NATIVE_EXPORT;
1189 POPSTACK_TO(PL_mainstack);
1192 PerlIO_printf(Perl_error_log, "panic: restartop\n");
1202 S_run_body(pTHX_ va_list args)
1205 I32 oldscope = va_arg(args, I32);
1207 DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
1208 PL_sawampersand ? "Enabling" : "Omitting"));
1210 if (!PL_restartop) {
1211 DEBUG_x(dump_all());
1212 DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
1213 DEBUG_S(PerlIO_printf(Perl_debug_log, "main thread is 0x%"UVxf"\n",
1217 PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename);
1220 if (PERLDB_SINGLE && PL_DBsingle)
1221 sv_setiv(PL_DBsingle, 1);
1223 call_list(oldscope, PL_initav);
1229 PL_op = PL_restartop;
1233 else if (PL_main_start) {
1234 CvDEPTH(PL_main_cv) = 1;
1235 PL_op = PL_main_start;
1245 Perl_get_sv(pTHX_ const char *name, I32 create)
1249 if (name[1] == '\0' && !isALPHA(name[0])) {
1250 PADOFFSET tmp = find_threadsv(name);
1251 if (tmp != NOT_IN_PAD) {
1253 return THREADSV(tmp);
1256 #endif /* USE_THREADS */
1257 gv = gv_fetchpv(name, create, SVt_PV);
1264 Perl_get_av(pTHX_ const char *name, I32 create)
1266 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
1275 Perl_get_hv(pTHX_ const char *name, I32 create)
1277 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
1286 Perl_get_cv(pTHX_ const char *name, I32 create)
1288 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
1289 /* XXX unsafe for threads if eval_owner isn't held */
1290 /* XXX this is probably not what they think they're getting.
1291 * It has the same effect as "sub name;", i.e. just a forward
1293 if (create && !GvCVu(gv))
1294 return newSUB(start_subparse(FALSE, 0),
1295 newSVOP(OP_CONST, 0, newSVpv(name,0)),
1303 /* Be sure to refetch the stack pointer after calling these routines. */
1306 Perl_call_argv(pTHX_ const char *sub_name, I32 flags, register char **argv)
1308 /* See G_* flags in cop.h */
1309 /* null terminated arg list */
1316 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
1321 return call_pv(sub_name, flags);
1325 Perl_call_pv(pTHX_ const char *sub_name, I32 flags)
1326 /* name of the subroutine */
1327 /* See G_* flags in cop.h */
1329 return call_sv((SV*)get_cv(sub_name, TRUE), flags);
1333 Perl_call_method(pTHX_ const char *methname, I32 flags)
1334 /* name of the subroutine */
1335 /* See G_* flags in cop.h */
1341 XPUSHs(sv_2mortal(newSVpv(methname,0)));
1346 return call_sv(*PL_stack_sp--, flags);
1349 /* May be called with any of a CV, a GV, or an SV containing the name. */
1351 Perl_call_sv(pTHX_ SV *sv, I32 flags)
1353 /* See G_* flags in cop.h */
1356 LOGOP myop; /* fake syntax tree node */
1360 bool oldcatch = CATCH_GET;
1365 if (flags & G_DISCARD) {
1370 Zero(&myop, 1, LOGOP);
1371 myop.op_next = Nullop;
1372 if (!(flags & G_NOARGS))
1373 myop.op_flags |= OPf_STACKED;
1374 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1375 (flags & G_ARRAY) ? OPf_WANT_LIST :
1380 EXTEND(PL_stack_sp, 1);
1381 *++PL_stack_sp = sv;
1383 oldscope = PL_scopestack_ix;
1385 if (PERLDB_SUB && PL_curstash != PL_debstash
1386 /* Handle first BEGIN of -d. */
1387 && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub)))
1388 /* Try harder, since this may have been a sighandler, thus
1389 * curstash may be meaningless. */
1390 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != PL_debstash)
1391 && !(flags & G_NODEBUG))
1392 PL_op->op_private |= OPpENTERSUB_DB;
1394 if (!(flags & G_EVAL)) {
1396 call_xbody((OP*)&myop, FALSE);
1397 retval = PL_stack_sp - (PL_stack_base + oldmark);
1398 CATCH_SET(oldcatch);
1401 cLOGOP->op_other = PL_op;
1403 /* we're trying to emulate pp_entertry() here */
1405 register PERL_CONTEXT *cx;
1406 I32 gimme = GIMME_V;
1411 push_return(PL_op->op_next);
1412 PUSHBLOCK(cx, CXt_EVAL, PL_stack_sp);
1414 PL_eval_root = PL_op; /* Only needed so that goto works right. */
1416 PL_in_eval = EVAL_INEVAL;
1417 if (flags & G_KEEPERR)
1418 PL_in_eval |= EVAL_KEEPERR;
1425 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_call_body),
1429 retval = PL_stack_sp - (PL_stack_base + oldmark);
1430 if (!(flags & G_KEEPERR))
1437 /* my_exit() was called */
1438 PL_curstash = PL_defstash;
1440 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
1441 Perl_croak(aTHX_ "Callback called exit");
1446 PL_op = PL_restartop;
1450 PL_stack_sp = PL_stack_base + oldmark;
1451 if (flags & G_ARRAY)
1455 *++PL_stack_sp = &PL_sv_undef;
1460 if (PL_scopestack_ix > oldscope) {
1464 register PERL_CONTEXT *cx;
1475 if (flags & G_DISCARD) {
1476 PL_stack_sp = PL_stack_base + oldmark;
1486 S_call_body(pTHX_ va_list args)
1488 OP *myop = va_arg(args, OP*);
1489 int is_eval = va_arg(args, int);
1491 call_xbody(myop, is_eval);
1496 S_call_xbody(pTHX_ OP *myop, int is_eval)
1500 if (PL_op == myop) {
1502 PL_op = Perl_pp_entereval(aTHX);
1504 PL_op = Perl_pp_entersub(aTHX);
1510 /* Eval a string. The G_EVAL flag is always assumed. */
1513 Perl_eval_sv(pTHX_ SV *sv, I32 flags)
1515 /* See G_* flags in cop.h */
1518 UNOP myop; /* fake syntax tree node */
1519 I32 oldmark = SP - PL_stack_base;
1526 if (flags & G_DISCARD) {
1533 Zero(PL_op, 1, UNOP);
1534 EXTEND(PL_stack_sp, 1);
1535 *++PL_stack_sp = sv;
1536 oldscope = PL_scopestack_ix;
1538 if (!(flags & G_NOARGS))
1539 myop.op_flags = OPf_STACKED;
1540 myop.op_next = Nullop;
1541 myop.op_type = OP_ENTEREVAL;
1542 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1543 (flags & G_ARRAY) ? OPf_WANT_LIST :
1545 if (flags & G_KEEPERR)
1546 myop.op_flags |= OPf_SPECIAL;
1549 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_call_body),
1553 retval = PL_stack_sp - (PL_stack_base + oldmark);
1554 if (!(flags & G_KEEPERR))
1561 /* my_exit() was called */
1562 PL_curstash = PL_defstash;
1564 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
1565 Perl_croak(aTHX_ "Callback called exit");
1570 PL_op = PL_restartop;
1574 PL_stack_sp = PL_stack_base + oldmark;
1575 if (flags & G_ARRAY)
1579 *++PL_stack_sp = &PL_sv_undef;
1584 if (flags & G_DISCARD) {
1585 PL_stack_sp = PL_stack_base + oldmark;
1595 Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
1598 SV* sv = newSVpv(p, 0);
1601 eval_sv(sv, G_SCALAR);
1608 if (croak_on_error && SvTRUE(ERRSV)) {
1610 Perl_croak(aTHX_ SvPVx(ERRSV, n_a));
1616 /* Require a module. */
1619 Perl_require_pv(pTHX_ const char *pv)
1623 PUSHSTACKi(PERLSI_REQUIRE);
1625 sv = sv_newmortal();
1626 sv_setpv(sv, "require '");
1629 eval_sv(sv, G_DISCARD);
1635 Perl_magicname(pTHX_ char *sym, char *name, I32 namlen)
1639 if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
1640 sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1644 S_usage(pTHX_ char *name) /* XXX move this out into a module ? */
1646 /* This message really ought to be max 23 lines.
1647 * Removed -h because the user already knows that opton. Others? */
1649 static char *usage_msg[] = {
1650 "-0[octal] specify record separator (\\0, if no argument)",
1651 "-a autosplit mode with -n or -p (splits $_ into @F)",
1652 "-c check syntax only (runs BEGIN and END blocks)",
1653 "-d[:debugger] run program under debugger",
1654 "-D[number/list] set debugging flags (argument is a bit mask or alphabets)",
1655 "-e 'command' one line of program (several -e's allowed, omit programfile)",
1656 "-F/pattern/ split() pattern for -a switch (//'s are optional)",
1657 "-i[extension] edit <> files in place (makes backup if extension supplied)",
1658 "-Idirectory specify @INC/#include directory (several -I's allowed)",
1659 "-l[octal] enable line ending processing, specifies line terminator",
1660 "-[mM][-]module execute `use/no module...' before executing program",
1661 "-n assume 'while (<>) { ... }' loop around program",
1662 "-p assume loop like -n but print line also, like sed",
1663 "-P run program through C preprocessor before compilation",
1664 "-s enable rudimentary parsing for switches after programfile",
1665 "-S look for programfile using PATH environment variable",
1666 "-T enable tainting checks",
1667 "-u dump core after parsing program",
1668 "-U allow unsafe operations",
1669 "-v print version, subversion (includes VERY IMPORTANT perl info)",
1670 "-V[:variable] print configuration summary (or a single Config.pm variable)",
1671 "-w enable many useful warnings (RECOMMENDED)",
1672 "-x[directory] strip off text before #!perl line and perhaps cd to directory",
1676 char **p = usage_msg;
1678 printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
1680 printf("\n %s", *p++);
1683 /* This routine handles any switches that can be given during run */
1686 Perl_moreswitches(pTHX_ char *s)
1695 rschar = (U32)scan_oct(s, 4, &numlen);
1696 SvREFCNT_dec(PL_nrs);
1697 if (rschar & ~((U8)~0))
1698 PL_nrs = &PL_sv_undef;
1699 else if (!rschar && numlen >= 2)
1700 PL_nrs = newSVpvn("", 0);
1703 PL_nrs = newSVpvn(&ch, 1);
1709 PL_splitstr = savepv(s + 1);
1723 if (*s == ':' || *s == '=') {
1724 my_setenv("PERL5DB", Perl_form(aTHX_ "use Devel::%s;", ++s));
1728 PL_perldb = PERLDB_ALL;
1736 if (isALPHA(s[1])) {
1737 static char debopts[] = "psltocPmfrxuLHXDS";
1740 for (s++; *s && (d = strchr(debopts,*s)); s++)
1741 PL_debug |= 1 << (d - debopts);
1744 PL_debug = atoi(s+1);
1745 for (s++; isDIGIT(*s); s++) ;
1747 PL_debug |= 0x80000000;
1750 if (ckWARN_d(WARN_DEBUGGING))
1751 Perl_warner(aTHX_ WARN_DEBUGGING,
1752 "Recompile perl with -DDEBUGGING to use -D switch\n");
1753 for (s++; isALNUM(*s); s++) ;
1759 usage(PL_origargv[0]);
1763 Safefree(PL_inplace);
1764 PL_inplace = savepv(s+1);
1766 for (s = PL_inplace; *s && !isSPACE(*s); s++) ;
1769 if (*s == '-') /* Additional switches on #! line. */
1773 case 'I': /* -I handled both here and in parse_perl() */
1776 while (*s && isSPACE(*s))
1781 /* ignore trailing spaces (possibly followed by other switches) */
1783 for (e = p; *e && !isSPACE(*e); e++) ;
1787 } while (*p && *p != '-');
1788 e = savepvn(s, e-s);
1796 Perl_croak(aTHX_ "No directory specified for -I");
1804 PL_ors = savepv("\n");
1806 *PL_ors = (char)scan_oct(s, 3 + (*s == '0'), &numlen);
1811 if (RsPARA(PL_nrs)) {
1816 PL_ors = SvPV(PL_nrs, PL_orslen);
1817 PL_ors = savepvn(PL_ors, PL_orslen);
1821 forbid_setid("-M"); /* XXX ? */
1824 forbid_setid("-m"); /* XXX ? */
1829 /* -M-foo == 'no foo' */
1830 if (*s == '-') { use = "no "; ++s; }
1831 sv = newSVpv(use,0);
1833 /* We allow -M'Module qw(Foo Bar)' */
1834 while(isALNUM(*s) || *s==':') ++s;
1836 sv_catpv(sv, start);
1837 if (*(start-1) == 'm') {
1839 Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
1840 sv_catpv( sv, " ()");
1843 sv_catpvn(sv, start, s-start);
1844 sv_catpv(sv, " split(/,/,q{");
1850 PL_preambleav = newAV();
1851 av_push(PL_preambleav, sv);
1854 Perl_croak(aTHX_ "No space allowed after -%c", *(s-1));
1866 PL_doswitches = TRUE;
1871 Perl_croak(aTHX_ "Too late for \"-T\" option");
1875 PL_do_undump = TRUE;
1883 printf("\nThis is perl, v%"UVuf".%"UVuf".%"UVuf" built for %s",
1884 (UV)PERL_REVISION, (UV)PERL_VERSION, (UV)PERL_SUBVERSION, ARCHNAME);
1885 #if defined(LOCAL_PATCH_COUNT)
1886 if (LOCAL_PATCH_COUNT > 0)
1887 printf("\n(with %d registered patch%s, see perl -V for more detail)",
1888 (int)LOCAL_PATCH_COUNT, (LOCAL_PATCH_COUNT!=1) ? "es" : "");
1891 printf("\n\nCopyright 1987-1999, Larry Wall\n");
1893 printf("\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
1896 printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
1897 printf("djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
1900 printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
1901 "Version 5 port Copyright (c) 1994-1999, Andreas Kaiser, Ilya Zakharevich\n");
1904 printf("atariST series port, ++jrb bammi@cadence.com\n");
1907 printf("BeOS port Copyright Tom Spindler, 1997-1999\n");
1910 printf("MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-1999\n");
1913 printf("MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
1916 printf("Stratus VOS port by Paul_Green@stratus.com, 1997-1999\n");
1919 printf("VM/ESA port by Neale Ferguson, 1998-1999\n");
1922 printf("BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
1925 printf("MiNT port by Guido Flohr, 1997-1999\n");
1927 #ifdef BINARY_BUILD_NOTICE
1928 BINARY_BUILD_NOTICE;
1931 Perl may be copied only under the terms of either the Artistic License or the\n\
1932 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n\
1933 Complete documentation for Perl, including FAQ lists, should be found on\n\
1934 this system using `man perl' or `perldoc perl'. If you have access to the\n\
1935 Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n");
1938 if (! (PL_dowarn & G_WARN_ALL_MASK))
1939 PL_dowarn |= G_WARN_ON;
1943 PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
1944 PL_compiling.cop_warnings = WARN_ALL ;
1948 PL_dowarn = G_WARN_ALL_OFF;
1949 PL_compiling.cop_warnings = WARN_NONE ;
1954 if (s[1] == '-') /* Additional switches on #! line. */
1959 #if defined(WIN32) || !defined(PERL_STRICT_CR)
1965 #ifdef ALTERNATE_SHEBANG
1966 case 'S': /* OS/2 needs -S on "extproc" line. */
1974 Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
1979 /* compliments of Tom Christiansen */
1981 /* unexec() can be found in the Gnu emacs distribution */
1982 /* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
1985 Perl_my_unexec(pTHX)
1993 prog = newSVpv(BIN_EXP, 0);
1994 sv_catpv(prog, "/perl");
1995 file = newSVpv(PL_origfilename, 0);
1996 sv_catpv(file, ".perldump");
1998 unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
1999 /* unexec prints msg to stderr in case of failure */
2000 PerlProc_exit(status);
2003 # include <lib$routines.h>
2004 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
2006 ABORT(); /* for use with undump */
2011 /* initialize curinterp */
2016 #ifdef PERL_OBJECT /* XXX kludge */
2019 PL_chopset = " \n-"; \
2020 PL_copline = NOLINE; \
2021 PL_curcop = &PL_compiling;\
2022 PL_curcopdb = NULL; \
2024 PL_dumpindent = 4; \
2025 PL_laststatval = -1; \
2026 PL_laststype = OP_STAT; \
2027 PL_maxscream = -1; \
2028 PL_maxsysfd = MAXSYSFD; \
2029 PL_statname = Nullsv; \
2030 PL_tmps_floor = -1; \
2032 PL_op_mask = NULL; \
2033 PL_laststatval = -1; \
2034 PL_laststype = OP_STAT; \
2035 PL_mess_sv = Nullsv; \
2036 PL_splitstr = " "; \
2037 PL_generation = 100; \
2038 PL_exitlist = NULL; \
2039 PL_exitlistlen = 0; \
2041 PL_in_clean_objs = FALSE; \
2042 PL_in_clean_all = FALSE; \
2043 PL_profiledata = NULL; \
2045 PL_rsfp_filters = Nullav; \
2050 # ifdef MULTIPLICITY
2051 # define PERLVAR(var,type)
2052 # define PERLVARA(var,n,type)
2053 # if defined(PERL_IMPLICIT_CONTEXT)
2054 # if defined(USE_THREADS)
2055 # define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
2056 # define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
2057 # else /* !USE_THREADS */
2058 # define PERLVARI(var,type,init) aTHX->var = init;
2059 # define PERLVARIC(var,type,init) aTHX->var = init;
2060 # endif /* USE_THREADS */
2062 # define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
2063 # define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
2065 # include "intrpvar.h"
2066 # ifndef USE_THREADS
2067 # include "thrdvar.h"
2074 # define PERLVAR(var,type)
2075 # define PERLVARA(var,n,type)
2076 # define PERLVARI(var,type,init) PL_##var = init;
2077 # define PERLVARIC(var,type,init) PL_##var = init;
2078 # include "intrpvar.h"
2079 # ifndef USE_THREADS
2080 # include "thrdvar.h"
2092 S_init_main_stash(pTHX)
2097 /* Note that strtab is a rather special HV. Assumptions are made
2098 about not iterating on it, and not adding tie magic to it.
2099 It is properly deallocated in perl_destruct() */
2100 PL_strtab = newHV();
2102 MUTEX_INIT(&PL_strtab_mutex);
2104 HvSHAREKEYS_off(PL_strtab); /* mandatory */
2105 hv_ksplit(PL_strtab, 512);
2107 PL_curstash = PL_defstash = newHV();
2108 PL_curstname = newSVpvn("main",4);
2109 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
2110 SvREFCNT_dec(GvHV(gv));
2111 GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);
2113 HvNAME(PL_defstash) = savepv("main");
2114 PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
2115 GvMULTI_on(PL_incgv);
2116 PL_hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */
2117 GvMULTI_on(PL_hintgv);
2118 PL_defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
2119 PL_errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
2120 GvMULTI_on(PL_errgv);
2121 PL_replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */
2122 GvMULTI_on(PL_replgv);
2123 (void)Perl_form(aTHX_ "%240s",""); /* Preallocate temp - for immediate signals. */
2124 sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
2125 sv_setpvn(ERRSV, "", 0);
2126 PL_curstash = PL_defstash;
2127 CopSTASH_set(&PL_compiling, PL_defstash);
2128 PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
2129 PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
2130 /* We must init $/ before switches are processed. */
2131 sv_setpvn(get_sv("/", TRUE), "\n", 1);
2135 S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript)
2143 PL_origfilename = savepv("-e");
2146 /* if find_script() returns, it returns a malloc()-ed value */
2147 PL_origfilename = scriptname = find_script(scriptname, dosearch, NULL, 1);
2149 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
2150 char *s = scriptname + 8;
2151 *fdscript = atoi(s);
2155 scriptname = savepv(s + 1);
2156 Safefree(PL_origfilename);
2157 PL_origfilename = scriptname;
2162 CopFILE_set(PL_curcop, PL_origfilename);
2163 if (strEQ(PL_origfilename,"-"))
2165 if (*fdscript >= 0) {
2166 PL_rsfp = PerlIO_fdopen(*fdscript,PERL_SCRIPT_MODE);
2167 #if defined(HAS_FCNTL) && defined(F_SETFD)
2169 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1); /* ensure close-on-exec */
2172 else if (PL_preprocess) {
2173 char *cpp_cfg = CPPSTDIN;
2174 SV *cpp = newSVpvn("",0);
2175 SV *cmd = NEWSV(0,0);
2177 if (strEQ(cpp_cfg, "cppstdin"))
2178 Perl_sv_catpvf(aTHX_ cpp, "%s/", BIN_EXP);
2179 sv_catpv(cpp, cpp_cfg);
2181 sv_catpvn(sv, "-I", 2);
2182 sv_catpv(sv,PRIVLIB_EXP);
2185 Perl_sv_setpvf(aTHX_ cmd, "\
2186 sed %s -e \"/^[^#]/b\" \
2187 -e \"/^#[ ]*include[ ]/b\" \
2188 -e \"/^#[ ]*define[ ]/b\" \
2189 -e \"/^#[ ]*if[ ]/b\" \
2190 -e \"/^#[ ]*ifdef[ ]/b\" \
2191 -e \"/^#[ ]*ifndef[ ]/b\" \
2192 -e \"/^#[ ]*else/b\" \
2193 -e \"/^#[ ]*elif[ ]/b\" \
2194 -e \"/^#[ ]*undef[ ]/b\" \
2195 -e \"/^#[ ]*endif/b\" \
2198 (PL_doextract ? "-e \"1,/^#/d\n\"" : ""),
2201 Perl_sv_setpvf(aTHX_ cmd, "\
2202 %s %s -e '/^[^#]/b' \
2203 -e '/^#[ ]*include[ ]/b' \
2204 -e '/^#[ ]*define[ ]/b' \
2205 -e '/^#[ ]*if[ ]/b' \
2206 -e '/^#[ ]*ifdef[ ]/b' \
2207 -e '/^#[ ]*ifndef[ ]/b' \
2208 -e '/^#[ ]*else/b' \
2209 -e '/^#[ ]*elif[ ]/b' \
2210 -e '/^#[ ]*undef[ ]/b' \
2211 -e '/^#[ ]*endif/b' \
2215 Perl_sv_setpvf(aTHX_ cmd, "\
2216 %s %s -e '/^[^#]/b' \
2217 -e '/^#[ ]*include[ ]/b' \
2218 -e '/^#[ ]*define[ ]/b' \
2219 -e '/^#[ ]*if[ ]/b' \
2220 -e '/^#[ ]*ifdef[ ]/b' \
2221 -e '/^#[ ]*ifndef[ ]/b' \
2222 -e '/^#[ ]*else/b' \
2223 -e '/^#[ ]*elif[ ]/b' \
2224 -e '/^#[ ]*undef[ ]/b' \
2225 -e '/^#[ ]*endif/b' \
2234 (PL_doextract ? "-e '1,/^#/d\n'" : ""),
2236 scriptname, cpp, sv, CPPMINUS);
2237 PL_doextract = FALSE;
2238 #ifdef IAMSUID /* actually, this is caught earlier */
2239 if (PL_euid != PL_uid && !PL_euid) { /* if running suidperl */
2241 (void)seteuid(PL_uid); /* musn't stay setuid root */
2244 (void)setreuid((Uid_t)-1, PL_uid);
2246 #ifdef HAS_SETRESUID
2247 (void)setresuid((Uid_t)-1, PL_uid, (Uid_t)-1);
2249 PerlProc_setuid(PL_uid);
2253 if (PerlProc_geteuid() != PL_uid)
2254 Perl_croak(aTHX_ "Can't do seteuid!\n");
2256 #endif /* IAMSUID */
2257 PL_rsfp = PerlProc_popen(SvPVX(cmd), "r");
2261 else if (!*scriptname) {
2262 forbid_setid("program input from stdin");
2263 PL_rsfp = PerlIO_stdin();
2266 PL_rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
2267 #if defined(HAS_FCNTL) && defined(F_SETFD)
2269 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1); /* ensure close-on-exec */
2274 #ifndef IAMSUID /* in case script is not readable before setuid */
2276 PerlLIO_stat(CopFILE(PL_curcop),&PL_statbuf) >= 0 &&
2277 PL_statbuf.st_mode & (S_ISUID|S_ISGID))
2280 PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, BIN_EXP,
2281 (int)PERL_REVISION, (int)PERL_VERSION,
2282 (int)PERL_SUBVERSION), PL_origargv);
2283 Perl_croak(aTHX_ "Can't do setuid\n");
2287 Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
2288 CopFILE(PL_curcop), Strerror(errno));
2293 * I_SYSSTATVFS HAS_FSTATVFS
2295 * I_STATFS HAS_FSTATFS
2296 * I_MNTENT HAS_GETMNTENT HAS_HASMNTOPT
2297 * here so that metaconfig picks them up. */
2301 S_fd_on_nosuid_fs(pTHX_ int fd)
2303 int check_okay = 0; /* able to do all the required sys/libcalls */
2304 int on_nosuid = 0; /* the fd is on a nosuid fs */
2306 * Preferred order: fstatvfs(), fstatfs(), ustat()+getmnt(), getmntent().
2307 * fstatvfs() is UNIX98.
2308 * fstatfs() is 4.3 BSD.
2309 * ustat()+getmnt() is pre-4.3 BSD.
2310 * getmntent() is O(number-of-mounted-filesystems) and can hang on
2311 * an irrelevant filesystem while trying to reach the right one.
2314 # ifdef HAS_FSTATVFS
2315 struct statvfs stfs;
2316 check_okay = fstatvfs(fd, &stfs) == 0;
2317 on_nosuid = check_okay && (stfs.f_flag & ST_NOSUID);
2319 # ifdef PERL_MOUNT_NOSUID
2320 # if defined(HAS_FSTATFS) && \
2321 defined(HAS_STRUCT_STATFS) && \
2322 defined(HAS_STRUCT_STATFS_F_FLAGS)
2324 check_okay = fstatfs(fd, &stfs) == 0;
2325 on_nosuid = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID);
2327 # if defined(HAS_FSTAT) && \
2328 defined(HAS_USTAT) && \
2329 defined(HAS_GETMNT) && \
2330 defined(HAS_STRUCT_FS_DATA) && \
2333 if (fstat(fd, &fdst) == 0) {
2335 if (ustat(fdst.st_dev, &us) == 0) {
2337 /* NOSTAT_ONE here because we're not examining fields which
2338 * vary between that case and STAT_ONE. */
2339 if (getmnt((int*)0, &fsd, (int)0, NOSTAT_ONE, us.f_fname) == 0) {
2340 size_t cmplen = sizeof(us.f_fname);
2341 if (sizeof(fsd.fd_req.path) < cmplen)
2342 cmplen = sizeof(fsd.fd_req.path);
2343 if (strnEQ(fsd.fd_req.path, us.f_fname, cmplen) &&
2344 fdst.st_dev == fsd.fd_req.dev) {
2346 on_nosuid = fsd.fd_req.flags & PERL_MOUNT_NOSUID;
2352 # endif /* fstat+ustat+getmnt */
2353 # endif /* fstatfs */
2355 # if defined(HAS_GETMNTENT) && \
2356 defined(HAS_HASMNTOPT) && \
2357 defined(MNTOPT_NOSUID)
2358 FILE *mtab = fopen("/etc/mtab", "r");
2359 struct mntent *entry;
2360 struct stat stb, fsb;
2362 if (mtab && (fstat(fd, &stb) == 0)) {
2363 while (entry = getmntent(mtab)) {
2364 if (stat(entry->mnt_dir, &fsb) == 0
2365 && fsb.st_dev == stb.st_dev)
2367 /* found the filesystem */
2369 if (hasmntopt(entry, MNTOPT_NOSUID))
2372 } /* A single fs may well fail its stat(). */
2377 # endif /* getmntent+hasmntopt */
2378 # endif /* PERL_MOUNT_NOSUID: fstatfs or fstat+ustat+statfs */
2379 # endif /* statvfs */
2382 Perl_croak(aTHX_ "Can't check filesystem of script \"%s\" for nosuid", PL_origfilename);
2385 #endif /* IAMSUID */
2388 S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript)
2392 /* do we need to emulate setuid on scripts? */
2394 /* This code is for those BSD systems that have setuid #! scripts disabled
2395 * in the kernel because of a security problem. Merely defining DOSUID
2396 * in perl will not fix that problem, but if you have disabled setuid
2397 * scripts in the kernel, this will attempt to emulate setuid and setgid
2398 * on scripts that have those now-otherwise-useless bits set. The setuid
2399 * root version must be called suidperl or sperlN.NNN. If regular perl
2400 * discovers that it has opened a setuid script, it calls suidperl with
2401 * the same argv that it had. If suidperl finds that the script it has
2402 * just opened is NOT setuid root, it sets the effective uid back to the
2403 * uid. We don't just make perl setuid root because that loses the
2404 * effective uid we had before invoking perl, if it was different from the
2407 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
2408 * be defined in suidperl only. suidperl must be setuid root. The
2409 * Configure script will set this up for you if you want it.
2416 if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0) /* normal stat is insecure */
2417 Perl_croak(aTHX_ "Can't stat script \"%s\"",PL_origfilename);
2418 if (fdscript < 0 && PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
2423 #ifndef HAS_SETREUID
2424 /* On this access check to make sure the directories are readable,
2425 * there is actually a small window that the user could use to make
2426 * filename point to an accessible directory. So there is a faint
2427 * chance that someone could execute a setuid script down in a
2428 * non-accessible directory. I don't know what to do about that.
2429 * But I don't think it's too important. The manual lies when
2430 * it says access() is useful in setuid programs.
2432 if (PerlLIO_access(CopFILE(PL_curcop),1)) /*double check*/
2433 Perl_croak(aTHX_ "Permission denied");
2435 /* If we can swap euid and uid, then we can determine access rights
2436 * with a simple stat of the file, and then compare device and
2437 * inode to make sure we did stat() on the same file we opened.
2438 * Then we just have to make sure he or she can execute it.
2441 struct stat tmpstatbuf;
2445 setreuid(PL_euid,PL_uid) < 0
2448 setresuid(PL_euid,PL_uid,(Uid_t)-1) < 0
2451 || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
2452 Perl_croak(aTHX_ "Can't swap uid and euid"); /* really paranoid */
2453 if (PerlLIO_stat(CopFILE(PL_curcop),&tmpstatbuf) < 0)
2454 Perl_croak(aTHX_ "Permission denied"); /* testing full pathname here */
2455 #if defined(IAMSUID) && !defined(NO_NOSUID_CHECK)
2456 if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp)))
2457 Perl_croak(aTHX_ "Permission denied");
2459 if (tmpstatbuf.st_dev != PL_statbuf.st_dev ||
2460 tmpstatbuf.st_ino != PL_statbuf.st_ino) {
2461 (void)PerlIO_close(PL_rsfp);
2462 if (PL_rsfp = PerlProc_popen("/bin/mail root","w")) { /* heh, heh */
2463 PerlIO_printf(PL_rsfp,
2464 "User %"Uid_t_f" tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
2465 (Filename of set-id script was %s, uid %"Uid_t_f" gid %"Gid_t_f".)\n\nSincerely,\nperl\n",
2466 PL_uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
2467 (long)PL_statbuf.st_dev, (long)PL_statbuf.st_ino,
2469 PL_statbuf.st_uid, PL_statbuf.st_gid);
2470 (void)PerlProc_pclose(PL_rsfp);
2472 Perl_croak(aTHX_ "Permission denied\n");
2476 setreuid(PL_uid,PL_euid) < 0
2478 # if defined(HAS_SETRESUID)
2479 setresuid(PL_uid,PL_euid,(Uid_t)-1) < 0
2482 || PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid)
2483 Perl_croak(aTHX_ "Can't reswap uid and euid");
2484 if (!cando(S_IXUSR,FALSE,&PL_statbuf)) /* can real uid exec? */
2485 Perl_croak(aTHX_ "Permission denied\n");
2487 #endif /* HAS_SETREUID */
2488 #endif /* IAMSUID */
2490 if (!S_ISREG(PL_statbuf.st_mode))
2491 Perl_croak(aTHX_ "Permission denied");
2492 if (PL_statbuf.st_mode & S_IWOTH)
2493 Perl_croak(aTHX_ "Setuid/gid script is writable by world");
2494 PL_doswitches = FALSE; /* -s is insecure in suid */
2495 CopLINE_inc(PL_curcop);
2496 if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch ||
2497 strnNE(SvPV(PL_linestr,n_a),"#!",2) ) /* required even on Sys V */
2498 Perl_croak(aTHX_ "No #! line");
2499 s = SvPV(PL_linestr,n_a)+2;
2501 while (!isSPACE(*s)) s++;
2502 for (s2 = s; (s2 > SvPV(PL_linestr,n_a)+2 &&
2503 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
2504 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
2505 Perl_croak(aTHX_ "Not a perl script");
2506 while (*s == ' ' || *s == '\t') s++;
2508 * #! arg must be what we saw above. They can invoke it by
2509 * mentioning suidperl explicitly, but they may not add any strange
2510 * arguments beyond what #! says if they do invoke suidperl that way.
2512 len = strlen(validarg);
2513 if (strEQ(validarg," PHOOEY ") ||
2514 strnNE(s,validarg,len) || !isSPACE(s[len]))
2515 Perl_croak(aTHX_ "Args must match #! line");
2518 if (PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
2519 PL_euid == PL_statbuf.st_uid)
2521 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2522 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2523 #endif /* IAMSUID */
2525 if (PL_euid) { /* oops, we're not the setuid root perl */
2526 (void)PerlIO_close(PL_rsfp);
2529 PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, BIN_EXP,
2530 (int)PERL_REVISION, (int)PERL_VERSION,
2531 (int)PERL_SUBVERSION), PL_origargv);
2533 Perl_croak(aTHX_ "Can't do setuid\n");
2536 if (PL_statbuf.st_mode & S_ISGID && PL_statbuf.st_gid != PL_egid) {
2538 (void)setegid(PL_statbuf.st_gid);
2541 (void)setregid((Gid_t)-1,PL_statbuf.st_gid);
2543 #ifdef HAS_SETRESGID
2544 (void)setresgid((Gid_t)-1,PL_statbuf.st_gid,(Gid_t)-1);
2546 PerlProc_setgid(PL_statbuf.st_gid);
2550 if (PerlProc_getegid() != PL_statbuf.st_gid)
2551 Perl_croak(aTHX_ "Can't do setegid!\n");
2553 if (PL_statbuf.st_mode & S_ISUID) {
2554 if (PL_statbuf.st_uid != PL_euid)
2556 (void)seteuid(PL_statbuf.st_uid); /* all that for this */
2559 (void)setreuid((Uid_t)-1,PL_statbuf.st_uid);
2561 #ifdef HAS_SETRESUID
2562 (void)setresuid((Uid_t)-1,PL_statbuf.st_uid,(Uid_t)-1);
2564 PerlProc_setuid(PL_statbuf.st_uid);
2568 if (PerlProc_geteuid() != PL_statbuf.st_uid)
2569 Perl_croak(aTHX_ "Can't do seteuid!\n");
2571 else if (PL_uid) { /* oops, mustn't run as root */
2573 (void)seteuid((Uid_t)PL_uid);
2576 (void)setreuid((Uid_t)-1,(Uid_t)PL_uid);
2578 #ifdef HAS_SETRESUID
2579 (void)setresuid((Uid_t)-1,(Uid_t)PL_uid,(Uid_t)-1);
2581 PerlProc_setuid((Uid_t)PL_uid);
2585 if (PerlProc_geteuid() != PL_uid)
2586 Perl_croak(aTHX_ "Can't do seteuid!\n");
2589 if (!cando(S_IXUSR,TRUE,&PL_statbuf))
2590 Perl_croak(aTHX_ "Permission denied\n"); /* they can't do this */
2593 else if (PL_preprocess)
2594 Perl_croak(aTHX_ "-P not allowed for setuid/setgid script\n");
2595 else if (fdscript >= 0)
2596 Perl_croak(aTHX_ "fd script not allowed in suidperl\n");
2598 Perl_croak(aTHX_ "Script is not setuid/setgid in suidperl\n");
2600 /* We absolutely must clear out any saved ids here, so we */
2601 /* exec the real perl, substituting fd script for scriptname. */
2602 /* (We pass script name as "subdir" of fd, which perl will grok.) */
2603 PerlIO_rewind(PL_rsfp);
2604 PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0); /* just in case rewind didn't */
2605 for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;
2606 if (!PL_origargv[which])
2607 Perl_croak(aTHX_ "Permission denied");
2608 PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s",
2609 PerlIO_fileno(PL_rsfp), PL_origargv[which]));
2610 #if defined(HAS_FCNTL) && defined(F_SETFD)
2611 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0); /* ensure no close-on-exec */
2613 PerlProc_execv(Perl_form(aTHX_ "%s/perl"PERL_FS_VER_FMT, BIN_EXP,
2614 (int)PERL_REVISION, (int)PERL_VERSION,
2615 (int)PERL_SUBVERSION), PL_origargv);/* try again */
2616 Perl_croak(aTHX_ "Can't do setuid\n");
2617 #endif /* IAMSUID */
2619 if (PL_euid != PL_uid || PL_egid != PL_gid) { /* (suidperl doesn't exist, in fact) */
2620 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
2622 PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf); /* may be either wrapped or real suid */
2623 if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
2625 (PL_egid != PL_gid && PL_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
2628 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2629 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2630 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
2631 /* not set-id, must be wrapped */
2637 S_find_beginning(pTHX)
2639 register char *s, *s2;
2641 /* skip forward in input to the real script? */
2644 while (PL_doextract) {
2645 if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch)
2646 Perl_croak(aTHX_ "No Perl script found in input\n");
2647 if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
2648 PerlIO_ungetc(PL_rsfp, '\n'); /* to keep line count right */
2649 PL_doextract = FALSE;
2650 while (*s && !(isSPACE (*s) || *s == '#')) s++;
2652 while (*s == ' ' || *s == '\t') s++;
2654 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2655 if (strnEQ(s2-4,"perl",4))
2657 while (s = moreswitches(s)) ;
2667 PL_uid = PerlProc_getuid();
2668 PL_euid = PerlProc_geteuid();
2669 PL_gid = PerlProc_getgid();
2670 PL_egid = PerlProc_getegid();
2672 PL_uid |= PL_gid << 16;
2673 PL_euid |= PL_egid << 16;
2675 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2679 S_forbid_setid(pTHX_ char *s)
2681 if (PL_euid != PL_uid)
2682 Perl_croak(aTHX_ "No %s allowed while running setuid", s);
2683 if (PL_egid != PL_gid)
2684 Perl_croak(aTHX_ "No %s allowed while running setgid", s);
2688 Perl_init_debugger(pTHX)
2691 HV *ostash = PL_curstash;
2693 PL_curstash = PL_debstash;
2694 PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2695 AvREAL_off(PL_dbargs);
2696 PL_DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2697 PL_DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2698 PL_DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2699 sv_upgrade(GvSV(PL_DBsub), SVt_IV); /* IVX accessed if PERLDB_SUB_NN */
2700 PL_DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2701 sv_setiv(PL_DBsingle, 0);
2702 PL_DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2703 sv_setiv(PL_DBtrace, 0);
2704 PL_DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2705 sv_setiv(PL_DBsignal, 0);
2706 PL_curstash = ostash;
2709 #ifndef STRESS_REALLOC
2710 #define REASONABLE(size) (size)
2712 #define REASONABLE(size) (1) /* unreasonable */
2716 Perl_init_stacks(pTHX)
2718 /* start with 128-item stack and 8K cxstack */
2719 PL_curstackinfo = new_stackinfo(REASONABLE(128),
2720 REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
2721 PL_curstackinfo->si_type = PERLSI_MAIN;
2722 PL_curstack = PL_curstackinfo->si_stack;
2723 PL_mainstack = PL_curstack; /* remember in case we switch stacks */
2725 PL_stack_base = AvARRAY(PL_curstack);
2726 PL_stack_sp = PL_stack_base;
2727 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
2729 New(50,PL_tmps_stack,REASONABLE(128),SV*);
2732 PL_tmps_max = REASONABLE(128);
2734 New(54,PL_markstack,REASONABLE(32),I32);
2735 PL_markstack_ptr = PL_markstack;
2736 PL_markstack_max = PL_markstack + REASONABLE(32);
2740 New(54,PL_scopestack,REASONABLE(32),I32);
2741 PL_scopestack_ix = 0;
2742 PL_scopestack_max = REASONABLE(32);
2744 New(54,PL_savestack,REASONABLE(128),ANY);
2745 PL_savestack_ix = 0;
2746 PL_savestack_max = REASONABLE(128);
2748 New(54,PL_retstack,REASONABLE(16),OP*);
2750 PL_retstack_max = REASONABLE(16);
2759 while (PL_curstackinfo->si_next)
2760 PL_curstackinfo = PL_curstackinfo->si_next;
2761 while (PL_curstackinfo) {
2762 PERL_SI *p = PL_curstackinfo->si_prev;
2763 /* curstackinfo->si_stack got nuked by sv_free_arenas() */
2764 Safefree(PL_curstackinfo->si_cxstack);
2765 Safefree(PL_curstackinfo);
2766 PL_curstackinfo = p;
2768 Safefree(PL_tmps_stack);
2769 Safefree(PL_markstack);
2770 Safefree(PL_scopestack);
2771 Safefree(PL_savestack);
2772 Safefree(PL_retstack);
2776 static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
2787 lex_start(PL_linestr);
2789 PL_subname = newSVpvn("main",4);
2793 S_init_predump_symbols(pTHX)
2800 sv_setpvn(get_sv("\"", TRUE), " ", 1);
2801 PL_stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2802 GvMULTI_on(PL_stdingv);
2803 io = GvIOp(PL_stdingv);
2804 IoIFP(io) = PerlIO_stdin();
2805 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2807 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
2809 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2812 IoOFP(io) = IoIFP(io) = PerlIO_stdout();
2814 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2816 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
2818 PL_stderrgv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2819 GvMULTI_on(PL_stderrgv);
2820 io = GvIOp(PL_stderrgv);
2821 IoOFP(io) = IoIFP(io) = PerlIO_stderr();
2822 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2824 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
2826 PL_statname = NEWSV(66,0); /* last filename we did stat on */
2829 PL_osname = savepv(OSNAME);
2833 S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
2840 argc--,argv++; /* skip name of script */
2841 if (PL_doswitches) {
2842 for (; argc > 0 && **argv == '-'; argc--,argv++) {
2845 if (argv[0][1] == '-' && !argv[0][2]) {
2849 if (s = strchr(argv[0], '=')) {
2851 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2854 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2857 PL_toptarget = NEWSV(0,0);
2858 sv_upgrade(PL_toptarget, SVt_PVFM);
2859 sv_setpvn(PL_toptarget, "", 0);
2860 PL_bodytarget = NEWSV(0,0);
2861 sv_upgrade(PL_bodytarget, SVt_PVFM);
2862 sv_setpvn(PL_bodytarget, "", 0);
2863 PL_formtarget = PL_bodytarget;
2866 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2867 sv_setpv(GvSV(tmpgv),PL_origfilename);
2868 magicname("0", "0", 1);
2870 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2872 sv_setpv(GvSV(tmpgv), os2_execname());
2874 sv_setpv(GvSV(tmpgv),PL_origargv[0]);
2876 if (PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2877 GvMULTI_on(PL_argvgv);
2878 (void)gv_AVadd(PL_argvgv);
2879 av_clear(GvAVn(PL_argvgv));
2880 for (; argc > 0; argc--,argv++) {
2881 av_push(GvAVn(PL_argvgv),newSVpv(argv[0],0));
2884 if (PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2886 GvMULTI_on(PL_envgv);
2887 hv = GvHVn(PL_envgv);
2888 hv_magic(hv, PL_envgv, 'E');
2889 #if !defined( VMS) && !defined(EPOC) /* VMS doesn't have environ array */
2890 /* Note that if the supplied env parameter is actually a copy
2891 of the global environ then it may now point to free'd memory
2892 if the environment has been modified since. To avoid this
2893 problem we treat env==NULL as meaning 'use the default'
2898 environ[0] = Nullch;
2899 for (; *env; env++) {
2900 if (!(s = strchr(*env,'=')))
2906 sv = newSVpv(s--,0);
2907 (void)hv_store(hv, *env, s - *env, sv, 0);
2909 #if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV)
2910 /* Sins of the RTL. See note in my_setenv(). */
2911 (void)PerlEnv_putenv(savepv(*env));
2915 #ifdef DYNAMIC_ENV_FETCH
2916 HvNAME(hv) = savepv(ENV_HV_NAME);
2920 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2921 sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
2925 S_init_perllib(pTHX)
2930 s = PerlEnv_getenv("PERL5LIB");
2934 incpush(PerlEnv_getenv("PERLLIB"), FALSE);
2936 /* Treat PERL5?LIB as a possible search list logical name -- the
2937 * "natural" VMS idiom for a Unix path string. We allow each
2938 * element to be a set of |-separated directories for compatibility.
2942 if (my_trnlnm("PERL5LIB",buf,0))
2943 do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
2945 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
2949 /* Use the ~-expanded versions of APPLLIB (undocumented),
2950 ARCHLIB PRIVLIB SITEARCH and SITELIB
2953 incpush(APPLLIB_EXP, TRUE);
2957 incpush(ARCHLIB_EXP, FALSE);
2960 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2963 incpush(PRIVLIB_EXP, TRUE);
2965 incpush(PRIVLIB_EXP, FALSE);
2969 incpush(SITEARCH_EXP, FALSE);
2973 incpush(SITELIB_EXP, TRUE);
2975 incpush(SITELIB_EXP, FALSE);
2978 #if defined(PERL_VENDORLIB_EXP)
2980 incpush(PERL_VENDORLIB_EXP, TRUE);
2982 incpush(PERL_VENDORLIB_EXP, FALSE);
2986 incpush(".", FALSE);
2990 # define PERLLIB_SEP ';'
2993 # define PERLLIB_SEP '|'
2995 # define PERLLIB_SEP ':'
2998 #ifndef PERLLIB_MANGLE
2999 # define PERLLIB_MANGLE(s,n) (s)
3003 S_incpush(pTHX_ char *p, int addsubdirs)
3005 SV *subdir = Nullsv;
3011 subdir = sv_newmortal();
3014 /* Break at all separators */
3016 SV *libdir = NEWSV(55,0);
3019 /* skip any consecutive separators */
3020 while ( *p == PERLLIB_SEP ) {
3021 /* Uncomment the next line for PATH semantics */
3022 /* av_push(GvAVn(PL_incgv), newSVpvn(".", 1)); */
3026 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
3027 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
3032 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
3033 p = Nullch; /* break out */
3037 * BEFORE pushing libdir onto @INC we may first push version- and
3038 * archname-specific sub-directories.
3041 struct stat tmpstatbuf;
3046 if ((unix = tounixspec_ts(SvPV(libdir,len),Nullch)) != Nullch) {
3048 while (unix[len-1] == '/') len--; /* Cosmetic */
3049 sv_usepvn(libdir,unix,len);
3052 PerlIO_printf(Perl_error_log,
3053 "Failed to unixify @INC element \"%s\"\n",
3056 /* .../archname/version if -d .../archname/version/auto */
3057 Perl_sv_setpvf(aTHX_ subdir, "%_/%s/"PERL_FS_VER_FMT"/auto", libdir,
3058 ARCHNAME, (int)PERL_REVISION,
3059 (int)PERL_VERSION, (int)PERL_SUBVERSION);
3060 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3061 S_ISDIR(tmpstatbuf.st_mode))
3062 av_push(GvAVn(PL_incgv),
3063 newSVpvn(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
3065 /* .../archname if -d .../archname/auto */
3066 Perl_sv_setpvf(aTHX_ subdir, "%_/%s/auto", libdir, ARCHNAME);
3067 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3068 S_ISDIR(tmpstatbuf.st_mode))
3069 av_push(GvAVn(PL_incgv),
3070 newSVpvn(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
3073 /* finally push this lib directory on the end of @INC */
3074 av_push(GvAVn(PL_incgv), libdir);
3079 STATIC struct perl_thread *
3080 S_init_main_thread(pTHX)
3082 #if !defined(PERL_IMPLICIT_CONTEXT)
3083 struct perl_thread *thr;
3087 Newz(53, thr, 1, struct perl_thread);
3088 PL_curcop = &PL_compiling;
3089 thr->interp = PERL_GET_INTERP;
3090 thr->cvcache = newHV();
3091 thr->threadsv = newAV();
3092 /* thr->threadsvp is set when find_threadsv is called */
3093 thr->specific = newAV();
3094 thr->flags = THRf_R_JOINABLE;
3095 MUTEX_INIT(&thr->mutex);
3096 /* Handcraft thrsv similarly to mess_sv */
3097 New(53, PL_thrsv, 1, SV);
3098 Newz(53, xpv, 1, XPV);
3099 SvFLAGS(PL_thrsv) = SVt_PV;
3100 SvANY(PL_thrsv) = (void*)xpv;
3101 SvREFCNT(PL_thrsv) = 1 << 30; /* practically infinite */
3102 SvPVX(PL_thrsv) = (char*)thr;
3103 SvCUR_set(PL_thrsv, sizeof(thr));
3104 SvLEN_set(PL_thrsv, sizeof(thr));
3105 *SvEND(PL_thrsv) = '\0'; /* in the trailing_nul field */
3106 thr->oursv = PL_thrsv;
3107 PL_chopset = " \n-";
3110 MUTEX_LOCK(&PL_threads_mutex);
3115 MUTEX_UNLOCK(&PL_threads_mutex);
3117 #ifdef HAVE_THREAD_INTERN
3118 Perl_init_thread_intern(thr);
3121 #ifdef SET_THREAD_SELF
3122 SET_THREAD_SELF(thr);
3124 thr->self = pthread_self();
3125 #endif /* SET_THREAD_SELF */
3129 * These must come after the SET_THR because sv_setpvn does
3130 * SvTAINT and the taint fields require dTHR.
3132 PL_toptarget = NEWSV(0,0);
3133 sv_upgrade(PL_toptarget, SVt_PVFM);
3134 sv_setpvn(PL_toptarget, "", 0);
3135 PL_bodytarget = NEWSV(0,0);
3136 sv_upgrade(PL_bodytarget, SVt_PVFM);
3137 sv_setpvn(PL_bodytarget, "", 0);
3138 PL_formtarget = PL_bodytarget;
3139 thr->errsv = newSVpvn("", 0);
3140 (void) find_threadsv("@"); /* Ensure $@ is initialised early */
3143 PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp);
3144 PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags);
3145 PL_regint_start = MEMBER_TO_FPTR(Perl_re_intuit_start);
3146 PL_regint_string = MEMBER_TO_FPTR(Perl_re_intuit_string);
3147 PL_regfree = MEMBER_TO_FPTR(Perl_pregfree);
3149 PL_reginterp_cnt = 0;
3153 #endif /* USE_THREADS */
3156 Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
3160 line_t oldline = CopLINE(PL_curcop);
3166 while (AvFILL(paramList) >= 0) {
3167 cv = (CV*)av_shift(paramList);
3169 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_call_list_body), cv);
3173 (void)SvPV(atsv, len);
3176 PL_curcop = &PL_compiling;
3177 CopLINE_set(PL_curcop, oldline);
3178 if (paramList == PL_beginav)
3179 sv_catpv(atsv, "BEGIN failed--compilation aborted");
3181 Perl_sv_catpvf(aTHX_ atsv,
3182 "%s failed--call queue aborted",
3183 paramList == PL_stopav ? "STOP"
3184 : paramList == PL_initav ? "INIT"
3186 while (PL_scopestack_ix > oldscope)
3188 Perl_croak(aTHX_ "%s", SvPVx(atsv, n_a));
3195 /* my_exit() was called */
3196 while (PL_scopestack_ix > oldscope)
3199 PL_curstash = PL_defstash;
3200 PL_curcop = &PL_compiling;
3201 CopLINE_set(PL_curcop, oldline);
3202 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED)) {
3203 if (paramList == PL_beginav)
3204 Perl_croak(aTHX_ "BEGIN failed--compilation aborted");
3206 Perl_croak(aTHX_ "%s failed--call queue aborted",
3207 paramList == PL_stopav ? "STOP"
3208 : paramList == PL_initav ? "INIT"
3215 PL_curcop = &PL_compiling;
3216 CopLINE_set(PL_curcop, oldline);
3219 PerlIO_printf(Perl_error_log, "panic: restartop\n");
3227 S_call_list_body(pTHX_ va_list args)
3230 CV *cv = va_arg(args, CV*);
3232 PUSHMARK(PL_stack_sp);
3233 call_sv((SV*)cv, G_EVAL|G_DISCARD);
3238 Perl_my_exit(pTHX_ U32 status)
3242 DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
3243 thr, (unsigned long) status));
3252 STATUS_NATIVE_SET(status);
3259 Perl_my_failure_exit(pTHX)
3262 if (vaxc$errno & 1) {
3263 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
3264 STATUS_NATIVE_SET(44);
3267 if (!vaxc$errno && errno) /* unlikely */
3268 STATUS_NATIVE_SET(44);
3270 STATUS_NATIVE_SET(vaxc$errno);
3275 STATUS_POSIX_SET(errno);
3277 exitstatus = STATUS_POSIX >> 8;
3278 if (exitstatus & 255)
3279 STATUS_POSIX_SET(exitstatus);
3281 STATUS_POSIX_SET(255);
3288 S_my_exit_jump(pTHX)
3291 register PERL_CONTEXT *cx;
3296 SvREFCNT_dec(PL_e_script);
3297 PL_e_script = Nullsv;
3300 POPSTACK_TO(PL_mainstack);
3301 if (cxstack_ix >= 0) {
3304 POPBLOCK(cx,PL_curpm);
3316 read_e_script(pTHXo_ int idx, SV *buf_sv, int maxlen)
3319 p = SvPVX(PL_e_script);
3320 nl = strchr(p, '\n');
3321 nl = (nl) ? nl+1 : SvEND(PL_e_script);
3323 filter_del(read_e_script);
3326 sv_catpvn(buf_sv, p, nl-p);
3327 sv_chop(PL_e_script, nl);