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
17 /* XXX If this causes problems, set i_unistd=undef in the hint file. */
22 #if !defined(STANDARD_C) && !defined(HAS_GETENV_PROTOTYPE)
23 char *getenv _((char *)); /* Usually in <stdlib.h> */
39 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
46 static I32 read_e_script _((CPerlObj* pPerl, int idx, SV *buf_sv, int maxlen));
48 static void find_beginning _((void));
49 static void forbid_setid _((char *));
50 static void incpush _((char *, int));
51 static void init_interp _((void));
52 static void init_ids _((void));
53 static void init_debugger _((void));
54 static void init_lexer _((void));
55 static void init_main_stash _((void));
56 static void *perl_parse_body _((va_list args));
57 static void *perl_run_body _((va_list args));
58 static void *perl_call_body _((va_list args));
59 static void perl_call_xbody _((OP *myop, int is_eval));
60 static void *call_list_body _((va_list args));
62 static struct perl_thread * init_main_thread _((void));
63 #endif /* USE_THREADS */
64 static void init_perllib _((void));
65 static void init_postdump_symbols _((int, char **, char **));
66 static void init_predump_symbols _((void));
67 static void my_exit_jump _((void)) __attribute__((noreturn));
68 static void nuke_stacks _((void));
69 static void open_script _((char *, bool, SV *, int *fd));
70 static void usage _((char *));
72 static int fd_on_nosuid_fs _((int));
74 static void validate_suid _((char *, char*, int));
75 static I32 read_e_script _((int idx, SV *buf_sv, int maxlen));
79 CPerlObj* perl_alloc(IPerlMem* ipM, IPerlEnv* ipE, IPerlStdIO* ipStd,
80 IPerlLIO* ipLIO, IPerlDir* ipD, IPerlSock* ipS, IPerlProc* ipP)
82 CPerlObj* pPerl = new(ipM) CPerlObj(ipM, ipE, ipStd, ipLIO, ipD, ipS, ipP);
92 PerlInterpreter *sv_interp;
95 New(53, sv_interp, 1, PerlInterpreter);
98 #endif /* PERL_OBJECT */
104 perl_construct(register PerlInterpreter *sv_interp)
110 struct perl_thread *thr;
111 #endif /* FAKE_THREADS */
112 #endif /* USE_THREADS */
115 if (!(PL_curinterp = sv_interp))
121 Zero(sv_interp, 1, PerlInterpreter);
124 /* Init the real globals (and main thread)? */
129 #ifdef ALLOC_THREAD_KEY
132 if (pthread_key_create(&PL_thr_key, 0))
133 croak("panic: pthread_key_create");
135 MUTEX_INIT(&PL_sv_mutex);
137 * Safe to use basic SV functions from now on (though
138 * not things like mortals or tainting yet).
140 MUTEX_INIT(&PL_eval_mutex);
141 COND_INIT(&PL_eval_cond);
142 MUTEX_INIT(&PL_threads_mutex);
143 COND_INIT(&PL_nthreads_cond);
144 #ifdef EMULATE_ATOMIC_REFCOUNTS
145 MUTEX_INIT(&PL_svref_mutex);
146 #endif /* EMULATE_ATOMIC_REFCOUNTS */
148 MUTEX_INIT(&PL_cred_mutex);
150 thr = init_main_thread();
151 #endif /* USE_THREADS */
153 PL_protect = FUNC_NAME_TO_PTR(default_protect); /* for exceptions */
155 PL_curcop = &PL_compiling; /* needed by ckWARN, right away */
157 PL_linestr = NEWSV(65,79);
158 sv_upgrade(PL_linestr,SVt_PVIV);
160 if (!SvREADONLY(&PL_sv_undef)) {
161 /* set read-only and try to insure than we wont see REFCNT==0
164 SvREADONLY_on(&PL_sv_undef);
165 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
167 sv_setpv(&PL_sv_no,PL_No);
169 SvREADONLY_on(&PL_sv_no);
170 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
172 sv_setpv(&PL_sv_yes,PL_Yes);
174 SvREADONLY_on(&PL_sv_yes);
175 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
180 /* PL_sighandlerp = sighandler; */
182 PL_sighandlerp = sighandler;
184 PL_pidstatus = newHV();
188 * There is no way we can refer to them from Perl so close them to save
189 * space. The other alternative would be to provide STDAUX and STDPRN
192 (void)fclose(stdaux);
193 (void)fclose(stdprn);
197 PL_nrs = newSVpvn("\n", 1);
198 PL_rs = SvREFCNT_inc(PL_nrs);
203 PL_perl_destruct_level = 1;
205 if (PL_perl_destruct_level > 0)
210 PL_lex_state = LEX_NOTPARSING;
215 SET_NUMERIC_STANDARD();
216 #if defined(PERL_SUBVERSION) && PERL_SUBVERSION > 0
217 sprintf(PL_patchlevel, "%7.5f", (double) PERL_REVISION
218 + ((double) PERL_VERSION / (double) 1000)
219 + ((double) PERL_SUBVERSION / (double) 100000));
221 sprintf(PL_patchlevel, "%5.3f", (double) PERL_REVISION +
222 ((double) PERL_VERSION / (double) 1000));
225 #if defined(LOCAL_PATCH_COUNT)
226 PL_localpatches = local_patches; /* For possible -v */
229 PerlIO_init(); /* Hook to IO system */
231 PL_fdpid = newAV(); /* for remembering popen pids by fd */
232 PL_modglobal = newHV(); /* pointers to per-interpreter module globals */
235 New(51,PL_debname,128,char);
236 New(52,PL_debdelim,128,char);
246 perl_destruct(register PerlInterpreter *sv_interp)
250 int destruct_level; /* 0=none, 1=full, 2=full with checks */
255 #endif /* USE_THREADS */
258 if (!(PL_curinterp = sv_interp))
264 /* Pass 1 on any remaining threads: detach joinables, join zombies */
266 MUTEX_LOCK(&PL_threads_mutex);
267 DEBUG_S(PerlIO_printf(PerlIO_stderr(),
268 "perl_destruct: waiting for %d threads...\n",
270 for (t = thr->next; t != thr; t = t->next) {
271 MUTEX_LOCK(&t->mutex);
272 switch (ThrSTATE(t)) {
275 DEBUG_S(PerlIO_printf(PerlIO_stderr(),
276 "perl_destruct: joining zombie %p\n", t));
277 ThrSETSTATE(t, THRf_DEAD);
278 MUTEX_UNLOCK(&t->mutex);
281 * The SvREFCNT_dec below may take a long time (e.g. av
282 * may contain an object scalar whose destructor gets
283 * called) so we have to unlock threads_mutex and start
286 MUTEX_UNLOCK(&PL_threads_mutex);
288 SvREFCNT_dec((SV*)av);
289 DEBUG_S(PerlIO_printf(PerlIO_stderr(),
290 "perl_destruct: joined zombie %p OK\n", t));
292 case THRf_R_JOINABLE:
293 DEBUG_S(PerlIO_printf(PerlIO_stderr(),
294 "perl_destruct: detaching thread %p\n", t));
295 ThrSETSTATE(t, THRf_R_DETACHED);
297 * We unlock threads_mutex and t->mutex in the opposite order
298 * from which we locked them just so that DETACH won't
299 * deadlock if it panics. It's only a breach of good style
300 * not a bug since they are unlocks not locks.
302 MUTEX_UNLOCK(&PL_threads_mutex);
304 MUTEX_UNLOCK(&t->mutex);
307 DEBUG_S(PerlIO_printf(PerlIO_stderr(),
308 "perl_destruct: ignoring %p (state %u)\n",
310 MUTEX_UNLOCK(&t->mutex);
311 /* fall through and out */
314 /* We leave the above "Pass 1" loop with threads_mutex still locked */
316 /* Pass 2 on remaining threads: wait for the thread count to drop to one */
317 while (PL_nthreads > 1)
319 DEBUG_S(PerlIO_printf(PerlIO_stderr(),
320 "perl_destruct: final wait for %d threads\n",
322 COND_WAIT(&PL_nthreads_cond, &PL_threads_mutex);
324 /* At this point, we're the last thread */
325 MUTEX_UNLOCK(&PL_threads_mutex);
326 DEBUG_S(PerlIO_printf(PerlIO_stderr(), "perl_destruct: armageddon has arrived\n"));
327 MUTEX_DESTROY(&PL_threads_mutex);
328 COND_DESTROY(&PL_nthreads_cond);
329 #endif /* !defined(FAKE_THREADS) */
330 #endif /* USE_THREADS */
332 destruct_level = PL_perl_destruct_level;
336 if (s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL")) {
338 if (destruct_level < i)
351 /* We must account for everything. */
353 /* Destroy the main CV and syntax tree */
355 PL_curpad = AvARRAY(PL_comppad);
356 op_free(PL_main_root);
357 PL_main_root = Nullop;
359 PL_curcop = &PL_compiling;
360 PL_main_start = Nullop;
361 SvREFCNT_dec(PL_main_cv);
365 if (PL_sv_objcount) {
367 * Try to destruct global references. We do this first so that the
368 * destructors and destructees still exist. Some sv's might remain.
369 * Non-referenced objects are on their own.
374 /* unhook hooks which will soon be, or use, destroyed data */
375 SvREFCNT_dec(PL_warnhook);
376 PL_warnhook = Nullsv;
377 SvREFCNT_dec(PL_diehook);
379 SvREFCNT_dec(PL_parsehook);
380 PL_parsehook = Nullsv;
382 /* call exit list functions */
383 while (PL_exitlistlen-- > 0)
384 PL_exitlist[PL_exitlistlen].fn(PERL_OBJECT_THIS_ PL_exitlist[PL_exitlistlen].ptr);
386 Safefree(PL_exitlist);
388 if (destruct_level == 0){
390 DEBUG_P(debprofdump());
392 /* The exit() function will do everything that needs doing. */
396 /* loosen bonds of global variables */
399 (void)PerlIO_close(PL_rsfp);
403 /* Filters for program text */
404 SvREFCNT_dec(PL_rsfp_filters);
405 PL_rsfp_filters = Nullav;
408 PL_preprocess = FALSE;
414 PL_doswitches = FALSE;
415 PL_dowarn = G_WARN_OFF;
416 PL_doextract = FALSE;
417 PL_sawampersand = FALSE; /* must save all match strings */
418 PL_sawstudy = FALSE; /* do fbm_instr on all strings */
422 Safefree(PL_inplace);
426 SvREFCNT_dec(PL_e_script);
427 PL_e_script = Nullsv;
430 /* magical thingies */
432 Safefree(PL_ofs); /* $, */
435 Safefree(PL_ors); /* $\ */
438 SvREFCNT_dec(PL_rs); /* $/ */
441 SvREFCNT_dec(PL_nrs); /* $/ helper */
444 PL_multiline = 0; /* $* */
446 SvREFCNT_dec(PL_statname);
447 PL_statname = Nullsv;
450 /* defgv, aka *_ should be taken care of elsewhere */
452 /* clean up after study() */
453 SvREFCNT_dec(PL_lastscream);
454 PL_lastscream = Nullsv;
455 Safefree(PL_screamfirst);
457 Safefree(PL_screamnext);
460 /* startup and shutdown function lists */
461 SvREFCNT_dec(PL_beginav);
462 SvREFCNT_dec(PL_endav);
463 SvREFCNT_dec(PL_initav);
468 /* shortcuts just get cleared */
475 PL_argvoutgv = Nullgv;
477 PL_last_in_gv = Nullgv;
480 /* reset so print() ends up where we expect */
483 /* Prepare to destruct main symbol table. */
490 if (destruct_level >= 2) {
491 if (PL_scopestack_ix != 0)
492 warn("Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
493 (long)PL_scopestack_ix);
494 if (PL_savestack_ix != 0)
495 warn("Unbalanced saves: %ld more saves than restores\n",
496 (long)PL_savestack_ix);
497 if (PL_tmps_floor != -1)
498 warn("Unbalanced tmps: %ld more allocs than frees\n",
499 (long)PL_tmps_floor + 1);
500 if (cxstack_ix != -1)
501 warn("Unbalanced context: %ld more PUSHes than POPs\n",
502 (long)cxstack_ix + 1);
505 /* Now absolutely destruct everything, somehow or other, loops or no. */
507 SvFLAGS(PL_strtab) |= SVTYPEMASK; /* don't clean out strtab now */
508 while (PL_sv_count != 0 && PL_sv_count != last_sv_count) {
509 last_sv_count = PL_sv_count;
512 SvFLAGS(PL_strtab) &= ~SVTYPEMASK;
513 SvFLAGS(PL_strtab) |= SVt_PVHV;
515 /* Destruct the global string table. */
517 /* Yell and reset the HeVAL() slots that are still holding refcounts,
518 * so that sv_free() won't fail on them.
526 max = HvMAX(PL_strtab);
527 array = HvARRAY(PL_strtab);
531 warn("Unbalanced string table refcount: (%d) for \"%s\"",
532 HeVAL(hent) - Nullsv, HeKEY(hent));
533 HeVAL(hent) = Nullsv;
543 SvREFCNT_dec(PL_strtab);
545 if (PL_sv_count != 0)
546 warn("Scalars leaked: %ld\n", (long)PL_sv_count);
550 /* No SVs have survived, need to clean out */
552 PL_pidstatus = Nullhv;
553 Safefree(PL_origfilename);
554 Safefree(PL_archpat_auto);
555 Safefree(PL_reg_start_tmp);
557 Safefree(PL_reg_curpm);
558 Safefree(HeKEY_hek(&PL_hv_fetch_ent_mh));
559 Safefree(PL_op_mask);
561 PL_hints = 0; /* Reset hints. Should hints be per-interpreter ? */
563 DEBUG_P(debprofdump());
565 MUTEX_DESTROY(&PL_strtab_mutex);
566 MUTEX_DESTROY(&PL_sv_mutex);
567 MUTEX_DESTROY(&PL_eval_mutex);
568 MUTEX_DESTROY(&PL_cred_mutex);
569 COND_DESTROY(&PL_eval_cond);
570 #ifdef EMULATE_ATOMIC_REFCOUNTS
571 MUTEX_DESTROY(&PL_svref_mutex);
572 #endif /* EMULATE_ATOMIC_REFCOUNTS */
574 /* As the penultimate thing, free the non-arena SV for thrsv */
575 Safefree(SvPVX(PL_thrsv));
576 Safefree(SvANY(PL_thrsv));
579 #endif /* USE_THREADS */
581 /* As the absolutely last thing, free the non-arena SV for mess() */
584 /* it could have accumulated taint magic */
585 if (SvTYPE(PL_mess_sv) >= SVt_PVMG) {
588 for (mg = SvMAGIC(PL_mess_sv); mg; mg = moremagic) {
589 moremagic = mg->mg_moremagic;
590 if (mg->mg_ptr && mg->mg_type != 'g' && mg->mg_len >= 0)
591 Safefree(mg->mg_ptr);
595 /* we know that type >= SVt_PV */
596 SvOOK_off(PL_mess_sv);
597 Safefree(SvPVX(PL_mess_sv));
598 Safefree(SvANY(PL_mess_sv));
599 Safefree(PL_mess_sv);
608 perl_free(PerlInterpreter *sv_interp)
614 if (!(PL_curinterp = sv_interp))
622 perl_atexit(void (*fn) (CPerlObj*,void *), void *ptr)
624 perl_atexit(void (*fn) (void *), void *ptr)
627 Renew(PL_exitlist, PL_exitlistlen+1, PerlExitListEntry);
628 PL_exitlist[PL_exitlistlen].fn = fn;
629 PL_exitlist[PL_exitlistlen].ptr = ptr;
635 perl_parse(void (*xsinit) (CPerlObj*), int argc, char **argv, char **env)
637 perl_parse(PerlInterpreter *sv_interp, void (*xsinit) (void), int argc, char **argv, char **env)
644 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
647 croak("suidperl is no longer needed since the kernel can now execute\n\
648 setuid perl scripts securely.\n");
653 if (!(PL_curinterp = sv_interp))
657 #if defined(__DYNAMIC__) && (defined(NeXT) || defined(__NeXT__))
658 _dyld_lookup_and_bind
659 ("__environ", (unsigned long *) &environ_pointer, NULL);
664 #ifndef VMS /* VMS doesn't have environ array */
665 PL_origenviron = environ;
670 /* Come here if running an undumped a.out. */
672 PL_origfilename = savepv(argv[0]);
673 PL_do_undump = FALSE;
674 cxstack_ix = -1; /* start label stack again */
676 init_postdump_symbols(argc,argv,env);
681 PL_curpad = AvARRAY(PL_comppad);
682 op_free(PL_main_root);
683 PL_main_root = Nullop;
685 PL_main_start = Nullop;
686 SvREFCNT_dec(PL_main_cv);
690 oldscope = PL_scopestack_ix;
691 PL_dowarn = G_WARN_OFF;
693 CALLPROTECT(&ret, perl_parse_body, env
705 /* my_exit() was called */
706 while (PL_scopestack_ix > oldscope)
709 PL_curstash = PL_defstash;
711 call_list(oldscope, PL_endav);
712 return STATUS_NATIVE_EXPORT;
714 PerlIO_printf(PerlIO_stderr(), "panic: top_env\n");
720 perl_parse_body(va_list args)
723 int argc = PL_origargc;
724 char **argv = PL_origargv;
725 char **env = va_arg(args, char**);
726 char *scriptname = NULL;
728 VOL bool dosearch = FALSE;
735 typedef void (*xs_init_t)(void);
736 xs_init_t xsinit = va_arg(args, xs_init_t);
739 sv_setpvn(PL_linestr,"",0);
740 sv = newSVpvn("",0); /* first used for -I flags */
744 for (argc--,argv++; argc > 0; argc--,argv++) {
745 if (argv[0][0] != '-' || !argv[0][1])
749 validarg = " PHOOEY ";
756 #ifndef PERL_STRICT_CR
780 if (s = moreswitches(s))
790 if (PL_euid != PL_uid || PL_egid != PL_gid)
791 croak("No -e allowed in setuid scripts");
793 PL_e_script = newSVpvn("",0);
794 filter_add(read_e_script, NULL);
797 sv_catpv(PL_e_script, s);
799 sv_catpv(PL_e_script, argv[1]);
803 croak("No code specified for -e");
804 sv_catpv(PL_e_script, "\n");
807 case 'I': /* -I handled both here and in moreswitches() */
809 if (!*++s && (s=argv[1]) != Nullch) {
812 while (s && isSPACE(*s))
816 for (e = s; *e && !isSPACE(*e); e++) ;
823 } /* XXX else croak? */
827 PL_preprocess = TRUE;
837 PL_preambleav = newAV();
838 av_push(PL_preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
840 PL_Sv = newSVpv("print myconfig();",0);
842 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
844 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
846 #if defined(DEBUGGING) || defined(MULTIPLICITY)
847 sv_catpv(PL_Sv,"\" Compile-time options:");
849 sv_catpv(PL_Sv," DEBUGGING");
852 sv_catpv(PL_Sv," MULTIPLICITY");
854 sv_catpv(PL_Sv,"\\n\",");
856 #if defined(LOCAL_PATCH_COUNT)
857 if (LOCAL_PATCH_COUNT > 0) {
859 sv_catpv(PL_Sv,"\" Locally applied patches:\\n\",");
860 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
861 if (PL_localpatches[i])
862 sv_catpvf(PL_Sv,"q\" \t%s\n\",",PL_localpatches[i]);
866 sv_catpvf(PL_Sv,"\" Built under %s\\n\"",OSNAME);
869 sv_catpvf(PL_Sv,",\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
871 sv_catpvf(PL_Sv,",\" Compiled on %s\\n\"",__DATE__);
876 @env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; \
877 print \" \\%ENV:\\n @env\\n\" if @env; \
878 print \" \\@INC:\\n @INC\\n\";");
881 PL_Sv = newSVpv("config_vars(qw(",0);
882 sv_catpv(PL_Sv, ++s);
883 sv_catpv(PL_Sv, "))");
886 av_push(PL_preambleav, PL_Sv);
887 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
893 PL_cddir = savepv(s);
898 if (!*++s || isSPACE(*s)) {
902 /* catch use of gnu style long options */
903 if (strEQ(s, "version")) {
907 if (strEQ(s, "help")) {
914 croak("Unrecognized switch: -%s (-h will show valid options)",s);
920 #ifndef SECURE_INTERNAL_GETENV
923 (s = PerlEnv_getenv("PERL5OPT"))) {
926 if (*s == '-' && *(s+1) == 'T')
939 if (!strchr("DIMUdmw", *s))
940 croak("Illegal switch in PERL5OPT: -%c", *s);
947 scriptname = argv[0];
950 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
952 else if (scriptname == Nullch) {
954 if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
962 open_script(scriptname,dosearch,sv,&fdscript);
964 validate_suid(validarg, scriptname,fdscript);
969 PL_main_cv = PL_compcv = (CV*)NEWSV(1104,0);
970 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
971 CvUNIQUE_on(PL_compcv);
973 PL_comppad = newAV();
974 av_push(PL_comppad, Nullsv);
975 PL_curpad = AvARRAY(PL_comppad);
976 PL_comppad_name = newAV();
977 PL_comppad_name_fill = 0;
978 PL_min_intro_pending = 0;
981 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
982 PL_curpad[0] = (SV*)newAV();
983 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
984 CvOWNER(PL_compcv) = 0;
985 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
986 MUTEX_INIT(CvMUTEXP(PL_compcv));
987 #endif /* USE_THREADS */
989 comppadlist = newAV();
990 AvREAL_off(comppadlist);
991 av_store(comppadlist, 0, (SV*)PL_comppad_name);
992 av_store(comppadlist, 1, (SV*)PL_comppad);
993 CvPADLIST(PL_compcv) = comppadlist;
995 boot_core_UNIVERSAL();
998 (*xsinit)(PERL_OBJECT_THIS); /* in case linked C routines want magical variables */
999 #if defined(VMS) || defined(WIN32) || defined(DJGPP)
1003 init_predump_symbols();
1004 /* init_postdump_symbols not currently designed to be called */
1005 /* more than once (ENV isn't cleared first, for example) */
1006 /* But running with -u leaves %ENV & @ARGV undefined! XXX */
1008 init_postdump_symbols(argc,argv,env);
1012 /* now parse the script */
1014 SETERRNO(0,SS$_NORMAL);
1016 if (yyparse() || PL_error_count) {
1018 croak("%s had compilation errors.\n", PL_origfilename);
1020 croak("Execution of %s aborted due to compilation errors.\n",
1024 PL_curcop->cop_line = 0;
1025 PL_curstash = PL_defstash;
1026 PL_preprocess = FALSE;
1028 SvREFCNT_dec(PL_e_script);
1029 PL_e_script = Nullsv;
1032 /* now that script is parsed, we can modify record separator */
1033 SvREFCNT_dec(PL_rs);
1034 PL_rs = SvREFCNT_inc(PL_nrs);
1035 sv_setsv(perl_get_sv("/", TRUE), PL_rs);
1039 if (ckWARN(WARN_ONCE))
1040 gv_check(PL_defstash);
1046 if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
1047 dump_mstats("after compilation:");
1059 perl_run(PerlInterpreter *sv_interp)
1067 if (!(PL_curinterp = sv_interp))
1071 oldscope = PL_scopestack_ix;
1074 CALLPROTECT(&ret, perl_run_body, oldscope);
1077 cxstack_ix = -1; /* start context stack again */
1079 case 0: /* normal completion */
1080 case 2: /* my_exit() */
1081 while (PL_scopestack_ix > oldscope)
1084 PL_curstash = PL_defstash;
1086 call_list(oldscope, PL_endav);
1088 if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
1089 dump_mstats("after execution: ");
1091 return STATUS_NATIVE_EXPORT;
1094 POPSTACK_TO(PL_mainstack);
1097 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
1107 perl_run_body(va_list args)
1110 I32 oldscope = va_arg(args, I32);
1112 DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
1113 PL_sawampersand ? "Enabling" : "Omitting"));
1115 if (!PL_restartop) {
1116 DEBUG_x(dump_all());
1117 DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
1118 DEBUG_S(PerlIO_printf(Perl_debug_log, "main thread is 0x%lx\n",
1119 (unsigned long) thr));
1122 PerlIO_printf(PerlIO_stderr(), "%s syntax OK\n", PL_origfilename);
1125 if (PERLDB_SINGLE && PL_DBsingle)
1126 sv_setiv(PL_DBsingle, 1);
1128 call_list(oldscope, PL_initav);
1134 PL_op = PL_restartop;
1138 else if (PL_main_start) {
1139 CvDEPTH(PL_main_cv) = 1;
1140 PL_op = PL_main_start;
1148 perl_get_sv(const char *name, I32 create)
1152 if (name[1] == '\0' && !isALPHA(name[0])) {
1153 PADOFFSET tmp = find_threadsv(name);
1154 if (tmp != NOT_IN_PAD) {
1156 return THREADSV(tmp);
1159 #endif /* USE_THREADS */
1160 gv = gv_fetchpv(name, create, SVt_PV);
1167 perl_get_av(const char *name, I32 create)
1169 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
1178 perl_get_hv(const char *name, I32 create)
1180 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
1189 perl_get_cv(const char *name, I32 create)
1191 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
1192 /* XXX unsafe for threads if eval_owner isn't held */
1193 if (create && !GvCVu(gv))
1194 return newSUB(start_subparse(FALSE, 0),
1195 newSVOP(OP_CONST, 0, newSVpv(name,0)),
1203 /* Be sure to refetch the stack pointer after calling these routines. */
1206 perl_call_argv(const char *sub_name, I32 flags, register char **argv)
1208 /* See G_* flags in cop.h */
1209 /* null terminated arg list */
1216 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
1221 return perl_call_pv(sub_name, flags);
1225 perl_call_pv(const char *sub_name, I32 flags)
1226 /* name of the subroutine */
1227 /* See G_* flags in cop.h */
1229 return perl_call_sv((SV*)perl_get_cv(sub_name, TRUE), flags);
1233 perl_call_method(const char *methname, I32 flags)
1234 /* name of the subroutine */
1235 /* See G_* flags in cop.h */
1241 XPUSHs(sv_2mortal(newSVpv(methname,0)));
1246 return perl_call_sv(*PL_stack_sp--, flags);
1249 /* May be called with any of a CV, a GV, or an SV containing the name. */
1251 perl_call_sv(SV *sv, I32 flags)
1253 /* See G_* flags in cop.h */
1256 LOGOP myop; /* fake syntax tree node */
1260 bool oldcatch = CATCH_GET;
1264 if (flags & G_DISCARD) {
1269 Zero(&myop, 1, LOGOP);
1270 myop.op_next = Nullop;
1271 if (!(flags & G_NOARGS))
1272 myop.op_flags |= OPf_STACKED;
1273 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1274 (flags & G_ARRAY) ? OPf_WANT_LIST :
1279 EXTEND(PL_stack_sp, 1);
1280 *++PL_stack_sp = sv;
1282 oldscope = PL_scopestack_ix;
1284 if (PERLDB_SUB && PL_curstash != PL_debstash
1285 /* Handle first BEGIN of -d. */
1286 && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub)))
1287 /* Try harder, since this may have been a sighandler, thus
1288 * curstash may be meaningless. */
1289 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != PL_debstash)
1290 && !(flags & G_NODEBUG))
1291 PL_op->op_private |= OPpENTERSUB_DB;
1293 if (!(flags & G_EVAL)) {
1295 perl_call_xbody((OP*)&myop, FALSE);
1296 retval = PL_stack_sp - (PL_stack_base + oldmark);
1300 cLOGOP->op_other = PL_op;
1302 /* we're trying to emulate pp_entertry() here */
1304 register PERL_CONTEXT *cx;
1305 I32 gimme = GIMME_V;
1310 push_return(PL_op->op_next);
1311 PUSHBLOCK(cx, CXt_EVAL, PL_stack_sp);
1313 PL_eval_root = PL_op; /* Only needed so that goto works right. */
1316 if (flags & G_KEEPERR)
1324 CALLPROTECT(&ret, perl_call_body, (OP*)&myop, FALSE);
1327 retval = PL_stack_sp - (PL_stack_base + oldmark);
1328 if (!(flags & G_KEEPERR))
1335 /* my_exit() was called */
1336 PL_curstash = PL_defstash;
1339 croak("Callback called exit");
1344 PL_op = PL_restartop;
1348 PL_stack_sp = PL_stack_base + oldmark;
1349 if (flags & G_ARRAY)
1353 *++PL_stack_sp = &PL_sv_undef;
1358 if (PL_scopestack_ix > oldscope) {
1362 register PERL_CONTEXT *cx;
1373 if (flags & G_DISCARD) {
1374 PL_stack_sp = PL_stack_base + oldmark;
1384 perl_call_body(va_list args)
1386 OP *myop = va_arg(args, OP*);
1387 int is_eval = va_arg(args, int);
1389 perl_call_xbody(myop, is_eval);
1394 perl_call_xbody(OP *myop, int is_eval)
1398 if (PL_op == myop) {
1400 PL_op = pp_entereval(ARGS);
1402 PL_op = pp_entersub(ARGS);
1408 /* Eval a string. The G_EVAL flag is always assumed. */
1411 perl_eval_sv(SV *sv, I32 flags)
1413 /* See G_* flags in cop.h */
1416 UNOP myop; /* fake syntax tree node */
1417 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(&ret, perl_call_body, (OP*)&myop, TRUE);
1449 retval = PL_stack_sp - (PL_stack_base + oldmark);
1450 if (!(flags & G_KEEPERR))
1457 /* my_exit() was called */
1458 PL_curstash = PL_defstash;
1461 croak("Callback called exit");
1466 PL_op = PL_restartop;
1470 PL_stack_sp = PL_stack_base + oldmark;
1471 if (flags & G_ARRAY)
1475 *++PL_stack_sp = &PL_sv_undef;
1480 if (flags & G_DISCARD) {
1481 PL_stack_sp = PL_stack_base + oldmark;
1491 perl_eval_pv(const char *p, I32 croak_on_error)
1494 SV* sv = newSVpv(p, 0);
1497 perl_eval_sv(sv, G_SCALAR);
1504 if (croak_on_error && SvTRUE(ERRSV)) {
1506 croak(SvPVx(ERRSV, n_a));
1512 /* Require a module. */
1515 perl_require_pv(const char *pv)
1519 PUSHSTACKi(PERLSI_REQUIRE);
1521 sv = sv_newmortal();
1522 sv_setpv(sv, "require '");
1525 perl_eval_sv(sv, G_DISCARD);
1531 magicname(char *sym, char *name, I32 namlen)
1535 if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
1536 sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1540 usage(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 scripts under debugger",
1551 "-D[number/list] set debugging flags (argument is a bit mask or flags)",
1552 "-e 'command' one line of script. Several -e's allowed. Omit [programfile].",
1553 "-F/pattern/ split() pattern for autosplit (-a). The //'s are optional.",
1554 "-i[extension] edit <> files in place (make backup if extension supplied)",
1555 "-Idirectory specify @INC/#include directory (may be used more than once)",
1556 "-l[octal] enable line ending processing, specifies line terminator",
1557 "-[mM][-]module.. executes `use/no module...' before executing your script.",
1558 "-n assume 'while (<>) { ... }' loop around your script",
1559 "-p assume loop like -n but print line also like sed",
1560 "-P run script through C preprocessor before compilation",
1561 "-s enable some switch parsing for switches after script name",
1562 "-S look for the script using PATH environment variable",
1563 "-T turn on tainting checks",
1564 "-u dump core after parsing script",
1565 "-U allow unsafe operations",
1566 "-v print version number, patchlevel plus VERY IMPORTANT perl info",
1567 "-V[:variable] print perl configuration information",
1568 "-w TURN WARNINGS ON FOR COMPILATION OF YOUR SCRIPT. 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 moreswitches(char *s)
1592 rschar = 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", form("use Devel::%s;", ++s));
1625 PL_perldb = PERLDB_ALL;
1632 if (isALPHA(s[1])) {
1633 static char debopts[] = "psltocPmfrxuLHXDS";
1636 for (s++; *s && (d = strchr(debopts,*s)); s++)
1637 PL_debug |= 1 << (d - debopts);
1640 PL_debug = atoi(s+1);
1641 for (s++; isDIGIT(*s); s++) ;
1643 PL_debug |= 0x80000000;
1645 warn("Recompile perl with -DDEBUGGING to use -D switch\n");
1646 for (s++; isALNUM(*s); s++) ;
1651 usage(PL_origargv[0]);
1655 Safefree(PL_inplace);
1656 PL_inplace = savepv(s+1);
1658 for (s = PL_inplace; *s && !isSPACE(*s); s++) ;
1661 if (*s == '-') /* Additional switches on #! line. */
1665 case 'I': /* -I handled both here and in parse_perl() */
1668 while (*s && isSPACE(*s))
1672 for (e = s; *e && !isSPACE(*e); e++) ;
1673 p = savepvn(s, e-s);
1679 croak("No space allowed after -I");
1687 PL_ors = savepv("\n");
1689 *PL_ors = scan_oct(s, 3 + (*s == '0'), &numlen);
1694 if (RsPARA(PL_nrs)) {
1699 PL_ors = SvPV(PL_nrs, PL_orslen);
1700 PL_ors = savepvn(PL_ors, PL_orslen);
1704 forbid_setid("-M"); /* XXX ? */
1707 forbid_setid("-m"); /* XXX ? */
1712 /* -M-foo == 'no foo' */
1713 if (*s == '-') { use = "no "; ++s; }
1714 sv = newSVpv(use,0);
1716 /* We allow -M'Module qw(Foo Bar)' */
1717 while(isALNUM(*s) || *s==':') ++s;
1719 sv_catpv(sv, start);
1720 if (*(start-1) == 'm') {
1722 croak("Can't use '%c' after -mname", *s);
1723 sv_catpv( sv, " ()");
1726 sv_catpvn(sv, start, s-start);
1727 sv_catpv(sv, " split(/,/,q{");
1732 if (PL_preambleav == NULL)
1733 PL_preambleav = newAV();
1734 av_push(PL_preambleav, sv);
1737 croak("No space allowed after -%c", *(s-1));
1749 PL_doswitches = TRUE;
1754 croak("Too late for \"-T\" option");
1758 PL_do_undump = TRUE;
1766 #if defined(PERL_SUBVERSION) && PERL_SUBVERSION > 0
1767 printf("\nThis is perl, version %d.%03d_%02d built for %s",
1768 PERL_REVISION, PERL_VERSION, PERL_SUBVERSION, ARCHNAME);
1770 printf("\nThis is perl, version %s built for %s",
1771 PL_patchlevel, ARCHNAME);
1773 #if defined(LOCAL_PATCH_COUNT)
1774 if (LOCAL_PATCH_COUNT > 0)
1775 printf("\n(with %d registered patch%s, see perl -V for more detail)",
1776 LOCAL_PATCH_COUNT, (LOCAL_PATCH_COUNT!=1) ? "es" : "");
1779 printf("\n\nCopyright 1987-1999, Larry Wall\n");
1781 printf("\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
1784 printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
1785 printf("djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
1788 printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
1789 "Version 5 port Copyright (c) 1994-1999, Andreas Kaiser, Ilya Zakharevich\n");
1792 printf("atariST series port, ++jrb bammi@cadence.com\n");
1795 printf("BeOS port Copyright Tom Spindler, 1997-1999\n");
1798 printf("MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-1999\n");
1801 printf("MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
1804 printf("Stratus VOS port by Paul_Green@stratus.com, 1997-1999\n");
1807 printf("VM/ESA port by Neale Ferguson, 1998-1999\n");
1810 printf("BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
1813 printf("MiNT port by Guido Flohr, 1997-1999\n");
1815 #ifdef BINARY_BUILD_NOTICE
1816 BINARY_BUILD_NOTICE;
1819 Perl may be copied only under the terms of either the Artistic License or the\n\
1820 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n\
1821 Complete documentation for Perl, including FAQ lists, should be found on\n\
1822 this system using `man perl' or `perldoc perl'. If you have access to the\n\
1823 Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n");
1826 if (! (PL_dowarn & G_WARN_ALL_MASK))
1827 PL_dowarn |= G_WARN_ON;
1831 PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
1832 PL_compiling.cop_warnings = WARN_ALL ;
1836 PL_dowarn = G_WARN_ALL_OFF;
1837 PL_compiling.cop_warnings = WARN_NONE ;
1842 if (s[1] == '-') /* Additional switches on #! line. */
1847 #if defined(WIN32) || !defined(PERL_STRICT_CR)
1853 #ifdef ALTERNATE_SHEBANG
1854 case 'S': /* OS/2 needs -S on "extproc" line. */
1862 croak("Can't emulate -%.1s on #! line",s);
1867 /* compliments of Tom Christiansen */
1869 /* unexec() can be found in the Gnu emacs distribution */
1870 /* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
1881 prog = newSVpv(BIN_EXP, 0);
1882 sv_catpv(prog, "/perl");
1883 file = newSVpv(PL_origfilename, 0);
1884 sv_catpv(file, ".perldump");
1886 unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
1887 /* unexec prints msg to stderr in case of failure */
1888 PerlProc_exit(status);
1891 # include <lib$routines.h>
1892 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
1894 ABORT(); /* for use with undump */
1899 /* initialize curinterp */
1904 #ifdef PERL_OBJECT /* XXX kludge */
1907 PL_chopset = " \n-"; \
1908 PL_copline = NOLINE; \
1909 PL_curcop = &PL_compiling;\
1910 PL_curcopdb = NULL; \
1913 PL_dumpindent = 4; \
1914 PL_laststatval = -1; \
1915 PL_laststype = OP_STAT; \
1916 PL_maxscream = -1; \
1917 PL_maxsysfd = MAXSYSFD; \
1918 PL_statname = Nullsv; \
1919 PL_tmps_floor = -1; \
1921 PL_op_mask = NULL; \
1923 PL_laststatval = -1; \
1924 PL_laststype = OP_STAT; \
1925 PL_mess_sv = Nullsv; \
1926 PL_splitstr = " "; \
1927 PL_generation = 100; \
1928 PL_exitlist = NULL; \
1929 PL_exitlistlen = 0; \
1931 PL_in_clean_objs = FALSE; \
1932 PL_in_clean_all = FALSE; \
1933 PL_profiledata = NULL; \
1935 PL_rsfp_filters = Nullav; \
1940 # ifdef MULTIPLICITY
1941 # define PERLVAR(var,type)
1942 # define PERLVARI(var,type,init) PL_curinterp->var = init;
1943 # define PERLVARIC(var,type,init) PL_curinterp->var = init;
1944 # include "intrpvar.h"
1945 # ifndef USE_THREADS
1946 # include "thrdvar.h"
1952 # define PERLVAR(var,type)
1953 # define PERLVARI(var,type,init) PL_##var = init;
1954 # define PERLVARIC(var,type,init) PL_##var = init;
1955 # include "intrpvar.h"
1956 # ifndef USE_THREADS
1957 # include "thrdvar.h"
1968 init_main_stash(void)
1973 /* Note that strtab is a rather special HV. Assumptions are made
1974 about not iterating on it, and not adding tie magic to it.
1975 It is properly deallocated in perl_destruct() */
1976 PL_strtab = newHV();
1978 MUTEX_INIT(&PL_strtab_mutex);
1980 HvSHAREKEYS_off(PL_strtab); /* mandatory */
1981 hv_ksplit(PL_strtab, 512);
1983 PL_curstash = PL_defstash = newHV();
1984 PL_curstname = newSVpvn("main",4);
1985 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
1986 SvREFCNT_dec(GvHV(gv));
1987 GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);
1989 HvNAME(PL_defstash) = savepv("main");
1990 PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
1991 GvMULTI_on(PL_incgv);
1992 PL_hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */
1993 GvMULTI_on(PL_hintgv);
1994 PL_defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
1995 PL_errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
1996 GvMULTI_on(PL_errgv);
1997 PL_replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */
1998 GvMULTI_on(PL_replgv);
1999 (void)form("%240s",""); /* Preallocate temp - for immediate signals. */
2000 sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
2001 sv_setpvn(ERRSV, "", 0);
2002 PL_curstash = PL_defstash;
2003 PL_compiling.cop_stash = PL_defstash;
2004 PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
2005 PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
2006 /* We must init $/ before switches are processed. */
2007 sv_setpvn(perl_get_sv("/", TRUE), "\n", 1);
2011 open_script(char *scriptname, bool dosearch, SV *sv, int *fdscript)
2019 PL_origfilename = savepv("-e");
2022 /* if find_script() returns, it returns a malloc()-ed value */
2023 PL_origfilename = scriptname = find_script(scriptname, dosearch, NULL, 1);
2025 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
2026 char *s = scriptname + 8;
2027 *fdscript = atoi(s);
2031 scriptname = savepv(s + 1);
2032 Safefree(PL_origfilename);
2033 PL_origfilename = scriptname;
2038 PL_curcop->cop_filegv = gv_fetchfile(PL_origfilename);
2039 if (strEQ(PL_origfilename,"-"))
2041 if (*fdscript >= 0) {
2042 PL_rsfp = PerlIO_fdopen(*fdscript,PERL_SCRIPT_MODE);
2043 #if defined(HAS_FCNTL) && defined(F_SETFD)
2045 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1); /* ensure close-on-exec */
2048 else if (PL_preprocess) {
2049 char *cpp_cfg = CPPSTDIN;
2050 SV *cpp = newSVpvn("",0);
2051 SV *cmd = NEWSV(0,0);
2053 if (strEQ(cpp_cfg, "cppstdin"))
2054 sv_catpvf(cpp, "%s/", BIN_EXP);
2055 sv_catpv(cpp, cpp_cfg);
2058 sv_catpv(sv,PRIVLIB_EXP);
2062 sed %s -e \"/^[^#]/b\" \
2063 -e \"/^#[ ]*include[ ]/b\" \
2064 -e \"/^#[ ]*define[ ]/b\" \
2065 -e \"/^#[ ]*if[ ]/b\" \
2066 -e \"/^#[ ]*ifdef[ ]/b\" \
2067 -e \"/^#[ ]*ifndef[ ]/b\" \
2068 -e \"/^#[ ]*else/b\" \
2069 -e \"/^#[ ]*elif[ ]/b\" \
2070 -e \"/^#[ ]*undef[ ]/b\" \
2071 -e \"/^#[ ]*endif/b\" \
2074 (PL_doextract ? "-e \"1,/^#/d\n\"" : ""),
2078 %s %s -e '/^[^#]/b' \
2079 -e '/^#[ ]*include[ ]/b' \
2080 -e '/^#[ ]*define[ ]/b' \
2081 -e '/^#[ ]*if[ ]/b' \
2082 -e '/^#[ ]*ifdef[ ]/b' \
2083 -e '/^#[ ]*ifndef[ ]/b' \
2084 -e '/^#[ ]*else/b' \
2085 -e '/^#[ ]*elif[ ]/b' \
2086 -e '/^#[ ]*undef[ ]/b' \
2087 -e '/^#[ ]*endif/b' \
2092 %s %s -e '/^[^#]/b' \
2093 -e '/^#[ ]*include[ ]/b' \
2094 -e '/^#[ ]*define[ ]/b' \
2095 -e '/^#[ ]*if[ ]/b' \
2096 -e '/^#[ ]*ifdef[ ]/b' \
2097 -e '/^#[ ]*ifndef[ ]/b' \
2098 -e '/^#[ ]*else/b' \
2099 -e '/^#[ ]*elif[ ]/b' \
2100 -e '/^#[ ]*undef[ ]/b' \
2101 -e '/^#[ ]*endif/b' \
2110 (PL_doextract ? "-e '1,/^#/d\n'" : ""),
2112 scriptname, cpp, sv, CPPMINUS);
2113 PL_doextract = FALSE;
2114 #ifdef IAMSUID /* actually, this is caught earlier */
2115 if (PL_euid != PL_uid && !PL_euid) { /* if running suidperl */
2117 (void)seteuid(PL_uid); /* musn't stay setuid root */
2120 (void)setreuid((Uid_t)-1, PL_uid);
2122 #ifdef HAS_SETRESUID
2123 (void)setresuid((Uid_t)-1, PL_uid, (Uid_t)-1);
2125 PerlProc_setuid(PL_uid);
2129 if (PerlProc_geteuid() != PL_uid)
2130 croak("Can't do seteuid!\n");
2132 #endif /* IAMSUID */
2133 PL_rsfp = PerlProc_popen(SvPVX(cmd), "r");
2137 else if (!*scriptname) {
2138 forbid_setid("program input from stdin");
2139 PL_rsfp = PerlIO_stdin();
2142 PL_rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
2143 #if defined(HAS_FCNTL) && defined(F_SETFD)
2145 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1); /* ensure close-on-exec */
2150 #ifndef IAMSUID /* in case script is not readable before setuid */
2152 PerlLIO_stat(SvPVX(GvSV(PL_curcop->cop_filegv)),&PL_statbuf) >= 0 &&
2153 PL_statbuf.st_mode & (S_ISUID|S_ISGID))
2156 PerlProc_execv(form("%s/sperl%s", BIN_EXP, PL_patchlevel), PL_origargv);
2157 croak("Can't do setuid\n");
2161 croak("Can't open perl script \"%s\": %s\n",
2162 SvPVX(GvSV(PL_curcop->cop_filegv)), Strerror(errno));
2167 * I_SYSSTATVFS HAS_FSTATVFS
2169 * I_STATFS HAS_FSTATFS
2170 * I_MNTENT HAS_GETMNTENT HAS_HASMNTOPT
2171 * here so that metaconfig picks them up. */
2175 fd_on_nosuid_fs(int fd)
2180 * Preferred order: fstatvfs(), fstatfs(), getmntent().
2181 * fstatvfs() is UNIX98.
2183 * getmntent() is O(number-of-mounted-filesystems) and can hang.
2186 # ifdef HAS_FSTATVFS
2187 struct statvfs stfs;
2188 check_okay = fstatvfs(fd, &stfs) == 0;
2189 on_nosuid = check_okay && (stfs.f_flag & ST_NOSUID);
2191 # if defined(HAS_FSTATFS) && defined(HAS_STRUCT_STATFS_FLAGS)
2193 check_okay = fstatfs(fd, &stfs) == 0;
2194 # undef PERL_MOUNT_NOSUID
2195 # if !defined(PERL_MOUNT_NOSUID) && defined(MNT_NOSUID)
2196 # define PERL_MOUNT_NOSUID MNT_NOSUID
2198 # if !defined(PERL_MOUNT_NOSUID) && defined(MS_NOSUID)
2199 # define PERL_MOUNT_NOSUID MS_NOSUID
2201 # if !defined(PERL_MOUNT_NOSUID) && defined(M_NOSUID)
2202 # define PERL_MOUNT_NOSUID M_NOSUID
2204 # ifdef PERL_MOUNT_NOSUID
2205 on_nosuid = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID);
2208 # if defined(HAS_GETMNTENT) && defined(HAS_HASMNTOPT) && defined(MNTOPT_NOSUID)
2209 FILE *mtab = fopen("/etc/mtab", "r");
2210 struct mntent *entry;
2211 struct stat stb, fsb;
2213 if (mtab && (fstat(fd, &stb) == 0)) {
2214 while (entry = getmntent(mtab)) {
2215 if (stat(entry->mnt_dir, &fsb) == 0
2216 && fsb.st_dev == stb.st_dev)
2218 /* found the filesystem */
2220 if (hasmntopt(entry, MNTOPT_NOSUID))
2223 } /* A single fs may well fail its stat(). */
2228 # endif /* mntent */
2229 # endif /* statfs */
2230 # endif /* statvfs */
2232 croak("Can't check filesystem of script \"%s\"", PL_origfilename);
2235 #endif /* IAMSUID */
2238 validate_suid(char *validarg, char *scriptname, int fdscript)
2242 /* do we need to emulate setuid on scripts? */
2244 /* This code is for those BSD systems that have setuid #! scripts disabled
2245 * in the kernel because of a security problem. Merely defining DOSUID
2246 * in perl will not fix that problem, but if you have disabled setuid
2247 * scripts in the kernel, this will attempt to emulate setuid and setgid
2248 * on scripts that have those now-otherwise-useless bits set. The setuid
2249 * root version must be called suidperl or sperlN.NNN. If regular perl
2250 * discovers that it has opened a setuid script, it calls suidperl with
2251 * the same argv that it had. If suidperl finds that the script it has
2252 * just opened is NOT setuid root, it sets the effective uid back to the
2253 * uid. We don't just make perl setuid root because that loses the
2254 * effective uid we had before invoking perl, if it was different from the
2257 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
2258 * be defined in suidperl only. suidperl must be setuid root. The
2259 * Configure script will set this up for you if you want it.
2266 if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0) /* normal stat is insecure */
2267 croak("Can't stat script \"%s\"",PL_origfilename);
2268 if (fdscript < 0 && PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
2273 #ifndef HAS_SETREUID
2274 /* On this access check to make sure the directories are readable,
2275 * there is actually a small window that the user could use to make
2276 * filename point to an accessible directory. So there is a faint
2277 * chance that someone could execute a setuid script down in a
2278 * non-accessible directory. I don't know what to do about that.
2279 * But I don't think it's too important. The manual lies when
2280 * it says access() is useful in setuid programs.
2282 if (PerlLIO_access(SvPVX(GvSV(PL_curcop->cop_filegv)),1)) /*double check*/
2283 croak("Permission denied");
2285 /* If we can swap euid and uid, then we can determine access rights
2286 * with a simple stat of the file, and then compare device and
2287 * inode to make sure we did stat() on the same file we opened.
2288 * Then we just have to make sure he or she can execute it.
2291 struct stat tmpstatbuf;
2295 setreuid(PL_euid,PL_uid) < 0
2298 setresuid(PL_euid,PL_uid,(Uid_t)-1) < 0
2301 || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
2302 croak("Can't swap uid and euid"); /* really paranoid */
2303 if (PerlLIO_stat(SvPVX(GvSV(PL_curcop->cop_filegv)),&tmpstatbuf) < 0)
2304 croak("Permission denied"); /* testing full pathname here */
2305 #if defined(IAMSUID) && !defined(NO_NOSUID_CHECK)
2306 if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp)))
2307 croak("Permission denied");
2309 if (tmpstatbuf.st_dev != PL_statbuf.st_dev ||
2310 tmpstatbuf.st_ino != PL_statbuf.st_ino) {
2311 (void)PerlIO_close(PL_rsfp);
2312 if (PL_rsfp = PerlProc_popen("/bin/mail root","w")) { /* heh, heh */
2313 PerlIO_printf(PL_rsfp,
2314 "User %ld tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
2315 (Filename of set-id script was %s, uid %ld gid %ld.)\n\nSincerely,\nperl\n",
2316 (long)PL_uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
2317 (long)PL_statbuf.st_dev, (long)PL_statbuf.st_ino,
2318 SvPVX(GvSV(PL_curcop->cop_filegv)),
2319 (long)PL_statbuf.st_uid, (long)PL_statbuf.st_gid);
2320 (void)PerlProc_pclose(PL_rsfp);
2322 croak("Permission denied\n");
2326 setreuid(PL_uid,PL_euid) < 0
2328 # if defined(HAS_SETRESUID)
2329 setresuid(PL_uid,PL_euid,(Uid_t)-1) < 0
2332 || PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid)
2333 croak("Can't reswap uid and euid");
2334 if (!cando(S_IXUSR,FALSE,&PL_statbuf)) /* can real uid exec? */
2335 croak("Permission denied\n");
2337 #endif /* HAS_SETREUID */
2338 #endif /* IAMSUID */
2340 if (!S_ISREG(PL_statbuf.st_mode))
2341 croak("Permission denied");
2342 if (PL_statbuf.st_mode & S_IWOTH)
2343 croak("Setuid/gid script is writable by world");
2344 PL_doswitches = FALSE; /* -s is insecure in suid */
2345 PL_curcop->cop_line++;
2346 if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch ||
2347 strnNE(SvPV(PL_linestr,n_a),"#!",2) ) /* required even on Sys V */
2348 croak("No #! line");
2349 s = SvPV(PL_linestr,n_a)+2;
2351 while (!isSPACE(*s)) s++;
2352 for (s2 = s; (s2 > SvPV(PL_linestr,n_a)+2 &&
2353 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
2354 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
2355 croak("Not a perl script");
2356 while (*s == ' ' || *s == '\t') s++;
2358 * #! arg must be what we saw above. They can invoke it by
2359 * mentioning suidperl explicitly, but they may not add any strange
2360 * arguments beyond what #! says if they do invoke suidperl that way.
2362 len = strlen(validarg);
2363 if (strEQ(validarg," PHOOEY ") ||
2364 strnNE(s,validarg,len) || !isSPACE(s[len]))
2365 croak("Args must match #! line");
2368 if (PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
2369 PL_euid == PL_statbuf.st_uid)
2371 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2372 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2373 #endif /* IAMSUID */
2375 if (PL_euid) { /* oops, we're not the setuid root perl */
2376 (void)PerlIO_close(PL_rsfp);
2379 PerlProc_execv(form("%s/sperl%s", BIN_EXP, PL_patchlevel), PL_origargv);
2381 croak("Can't do setuid\n");
2384 if (PL_statbuf.st_mode & S_ISGID && PL_statbuf.st_gid != PL_egid) {
2386 (void)setegid(PL_statbuf.st_gid);
2389 (void)setregid((Gid_t)-1,PL_statbuf.st_gid);
2391 #ifdef HAS_SETRESGID
2392 (void)setresgid((Gid_t)-1,PL_statbuf.st_gid,(Gid_t)-1);
2394 PerlProc_setgid(PL_statbuf.st_gid);
2398 if (PerlProc_getegid() != PL_statbuf.st_gid)
2399 croak("Can't do setegid!\n");
2401 if (PL_statbuf.st_mode & S_ISUID) {
2402 if (PL_statbuf.st_uid != PL_euid)
2404 (void)seteuid(PL_statbuf.st_uid); /* all that for this */
2407 (void)setreuid((Uid_t)-1,PL_statbuf.st_uid);
2409 #ifdef HAS_SETRESUID
2410 (void)setresuid((Uid_t)-1,PL_statbuf.st_uid,(Uid_t)-1);
2412 PerlProc_setuid(PL_statbuf.st_uid);
2416 if (PerlProc_geteuid() != PL_statbuf.st_uid)
2417 croak("Can't do seteuid!\n");
2419 else if (PL_uid) { /* oops, mustn't run as root */
2421 (void)seteuid((Uid_t)PL_uid);
2424 (void)setreuid((Uid_t)-1,(Uid_t)PL_uid);
2426 #ifdef HAS_SETRESUID
2427 (void)setresuid((Uid_t)-1,(Uid_t)PL_uid,(Uid_t)-1);
2429 PerlProc_setuid((Uid_t)PL_uid);
2433 if (PerlProc_geteuid() != PL_uid)
2434 croak("Can't do seteuid!\n");
2437 if (!cando(S_IXUSR,TRUE,&PL_statbuf))
2438 croak("Permission denied\n"); /* they can't do this */
2441 else if (PL_preprocess)
2442 croak("-P not allowed for setuid/setgid script\n");
2443 else if (fdscript >= 0)
2444 croak("fd script not allowed in suidperl\n");
2446 croak("Script is not setuid/setgid in suidperl\n");
2448 /* We absolutely must clear out any saved ids here, so we */
2449 /* exec the real perl, substituting fd script for scriptname. */
2450 /* (We pass script name as "subdir" of fd, which perl will grok.) */
2451 PerlIO_rewind(PL_rsfp);
2452 PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0); /* just in case rewind didn't */
2453 for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;
2454 if (!PL_origargv[which])
2455 croak("Permission denied");
2456 PL_origargv[which] = savepv(form("/dev/fd/%d/%s",
2457 PerlIO_fileno(PL_rsfp), PL_origargv[which]));
2458 #if defined(HAS_FCNTL) && defined(F_SETFD)
2459 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0); /* ensure no close-on-exec */
2461 PerlProc_execv(form("%s/perl%s", BIN_EXP, PL_patchlevel), PL_origargv);/* try again */
2462 croak("Can't do setuid\n");
2463 #endif /* IAMSUID */
2465 if (PL_euid != PL_uid || PL_egid != PL_gid) { /* (suidperl doesn't exist, in fact) */
2466 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
2468 PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf); /* may be either wrapped or real suid */
2469 if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
2471 (PL_egid != PL_gid && PL_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
2474 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2475 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2476 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
2477 /* not set-id, must be wrapped */
2483 find_beginning(void)
2485 register char *s, *s2;
2487 /* skip forward in input to the real script? */
2490 while (PL_doextract) {
2491 if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch)
2492 croak("No Perl script found in input\n");
2493 if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
2494 PerlIO_ungetc(PL_rsfp, '\n'); /* to keep line count right */
2495 PL_doextract = FALSE;
2496 while (*s && !(isSPACE (*s) || *s == '#')) s++;
2498 while (*s == ' ' || *s == '\t') s++;
2500 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2501 if (strnEQ(s2-4,"perl",4))
2503 while (s = moreswitches(s)) ;
2505 if (PL_cddir && PerlDir_chdir(PL_cddir) < 0)
2506 croak("Can't chdir to %s",PL_cddir);
2515 PL_uid = (int)PerlProc_getuid();
2516 PL_euid = (int)PerlProc_geteuid();
2517 PL_gid = (int)PerlProc_getgid();
2518 PL_egid = (int)PerlProc_getegid();
2520 PL_uid |= PL_gid << 16;
2521 PL_euid |= PL_egid << 16;
2523 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2527 forbid_setid(char *s)
2529 if (PL_euid != PL_uid)
2530 croak("No %s allowed while running setuid", s);
2531 if (PL_egid != PL_gid)
2532 croak("No %s allowed while running setgid", s);
2539 PL_curstash = PL_debstash;
2540 PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2541 AvREAL_off(PL_dbargs);
2542 PL_DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2543 PL_DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2544 PL_DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2545 PL_DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2546 sv_setiv(PL_DBsingle, 0);
2547 PL_DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2548 sv_setiv(PL_DBtrace, 0);
2549 PL_DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2550 sv_setiv(PL_DBsignal, 0);
2551 PL_curstash = PL_defstash;
2554 #ifndef STRESS_REALLOC
2555 #define REASONABLE(size) (size)
2557 #define REASONABLE(size) (1) /* unreasonable */
2561 init_stacks(ARGSproto)
2563 /* start with 128-item stack and 8K cxstack */
2564 PL_curstackinfo = new_stackinfo(REASONABLE(128),
2565 REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
2566 PL_curstackinfo->si_type = PERLSI_MAIN;
2567 PL_curstack = PL_curstackinfo->si_stack;
2568 PL_mainstack = PL_curstack; /* remember in case we switch stacks */
2570 PL_stack_base = AvARRAY(PL_curstack);
2571 PL_stack_sp = PL_stack_base;
2572 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
2574 New(50,PL_tmps_stack,REASONABLE(128),SV*);
2577 PL_tmps_max = REASONABLE(128);
2579 New(54,PL_markstack,REASONABLE(32),I32);
2580 PL_markstack_ptr = PL_markstack;
2581 PL_markstack_max = PL_markstack + REASONABLE(32);
2585 New(54,PL_scopestack,REASONABLE(32),I32);
2586 PL_scopestack_ix = 0;
2587 PL_scopestack_max = REASONABLE(32);
2589 New(54,PL_savestack,REASONABLE(128),ANY);
2590 PL_savestack_ix = 0;
2591 PL_savestack_max = REASONABLE(128);
2593 New(54,PL_retstack,REASONABLE(16),OP*);
2595 PL_retstack_max = REASONABLE(16);
2604 while (PL_curstackinfo->si_next)
2605 PL_curstackinfo = PL_curstackinfo->si_next;
2606 while (PL_curstackinfo) {
2607 PERL_SI *p = PL_curstackinfo->si_prev;
2608 /* curstackinfo->si_stack got nuked by sv_free_arenas() */
2609 Safefree(PL_curstackinfo->si_cxstack);
2610 Safefree(PL_curstackinfo);
2611 PL_curstackinfo = p;
2613 Safefree(PL_tmps_stack);
2614 Safefree(PL_markstack);
2615 Safefree(PL_scopestack);
2616 Safefree(PL_savestack);
2617 Safefree(PL_retstack);
2619 Safefree(PL_debname);
2620 Safefree(PL_debdelim);
2625 static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
2636 lex_start(PL_linestr);
2638 PL_subname = newSVpvn("main",4);
2642 init_predump_symbols(void)
2648 sv_setpvn(perl_get_sv("\"", TRUE), " ", 1);
2649 PL_stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2650 GvMULTI_on(PL_stdingv);
2651 IoIFP(GvIOp(PL_stdingv)) = PerlIO_stdin();
2652 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2654 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(PL_stdingv));
2656 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2658 IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = PerlIO_stdout();
2660 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2662 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(PL_defoutgv));
2664 othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2665 GvMULTI_on(othergv);
2666 IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = PerlIO_stderr();
2667 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2669 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv));
2671 PL_statname = NEWSV(66,0); /* last filename we did stat on */
2674 PL_osname = savepv(OSNAME);
2678 init_postdump_symbols(register int argc, register char **argv, register char **env)
2685 argc--,argv++; /* skip name of script */
2686 if (PL_doswitches) {
2687 for (; argc > 0 && **argv == '-'; argc--,argv++) {
2690 if (argv[0][1] == '-') {
2694 if (s = strchr(argv[0], '=')) {
2696 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2699 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2702 PL_toptarget = NEWSV(0,0);
2703 sv_upgrade(PL_toptarget, SVt_PVFM);
2704 sv_setpvn(PL_toptarget, "", 0);
2705 PL_bodytarget = NEWSV(0,0);
2706 sv_upgrade(PL_bodytarget, SVt_PVFM);
2707 sv_setpvn(PL_bodytarget, "", 0);
2708 PL_formtarget = PL_bodytarget;
2711 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2712 sv_setpv(GvSV(tmpgv),PL_origfilename);
2713 magicname("0", "0", 1);
2715 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2716 sv_setpv(GvSV(tmpgv),PL_origargv[0]);
2717 if (PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2718 GvMULTI_on(PL_argvgv);
2719 (void)gv_AVadd(PL_argvgv);
2720 av_clear(GvAVn(PL_argvgv));
2721 for (; argc > 0; argc--,argv++) {
2722 av_push(GvAVn(PL_argvgv),newSVpv(argv[0],0));
2725 if (PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2727 GvMULTI_on(PL_envgv);
2728 hv = GvHVn(PL_envgv);
2729 hv_magic(hv, PL_envgv, 'E');
2730 #ifndef VMS /* VMS doesn't have environ array */
2731 /* Note that if the supplied env parameter is actually a copy
2732 of the global environ then it may now point to free'd memory
2733 if the environment has been modified since. To avoid this
2734 problem we treat env==NULL as meaning 'use the default'
2739 environ[0] = Nullch;
2740 for (; *env; env++) {
2741 if (!(s = strchr(*env,'=')))
2747 sv = newSVpv(s--,0);
2748 (void)hv_store(hv, *env, s - *env, sv, 0);
2750 #if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV)
2751 /* Sins of the RTL. See note in my_setenv(). */
2752 (void)PerlEnv_putenv(savepv(*env));
2756 #ifdef DYNAMIC_ENV_FETCH
2757 HvNAME(hv) = savepv(ENV_HV_NAME);
2761 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2762 sv_setiv(GvSV(tmpgv), (IV)getpid());
2771 s = PerlEnv_getenv("PERL5LIB");
2775 incpush(PerlEnv_getenv("PERLLIB"), FALSE);
2777 /* Treat PERL5?LIB as a possible search list logical name -- the
2778 * "natural" VMS idiom for a Unix path string. We allow each
2779 * element to be a set of |-separated directories for compatibility.
2783 if (my_trnlnm("PERL5LIB",buf,0))
2784 do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
2786 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
2790 /* Use the ~-expanded versions of APPLLIB (undocumented),
2791 ARCHLIB PRIVLIB SITEARCH and SITELIB
2794 incpush(APPLLIB_EXP, TRUE);
2798 incpush(ARCHLIB_EXP, FALSE);
2801 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2804 incpush(PRIVLIB_EXP, TRUE);
2806 incpush(PRIVLIB_EXP, FALSE);
2810 incpush(SITEARCH_EXP, FALSE);
2814 incpush(SITELIB_EXP, TRUE);
2816 incpush(SITELIB_EXP, FALSE);
2820 incpush(".", FALSE);
2824 # define PERLLIB_SEP ';'
2827 # define PERLLIB_SEP '|'
2829 # define PERLLIB_SEP ':'
2832 #ifndef PERLLIB_MANGLE
2833 # define PERLLIB_MANGLE(s,n) (s)
2837 incpush(char *p, int addsubdirs)
2839 SV *subdir = Nullsv;
2845 subdir = sv_newmortal();
2846 if (!PL_archpat_auto) {
2847 STRLEN len = (sizeof(ARCHNAME) + strlen(PL_patchlevel)
2848 + sizeof("//auto"));
2849 New(55, PL_archpat_auto, len, char);
2850 sprintf(PL_archpat_auto, "/%s/%s/auto", ARCHNAME, PL_patchlevel);
2852 for (len = sizeof(ARCHNAME) + 2;
2853 PL_archpat_auto[len] != '\0' && PL_archpat_auto[len] != '/'; len++)
2854 if (PL_archpat_auto[len] == '.') PL_archpat_auto[len] = '_';
2859 /* Break at all separators */
2861 SV *libdir = NEWSV(55,0);
2864 /* skip any consecutive separators */
2865 while ( *p == PERLLIB_SEP ) {
2866 /* Uncomment the next line for PATH semantics */
2867 /* av_push(GvAVn(PL_incgv), newSVpvn(".", 1)); */
2871 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
2872 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
2877 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
2878 p = Nullch; /* break out */
2882 * BEFORE pushing libdir onto @INC we may first push version- and
2883 * archname-specific sub-directories.
2886 struct stat tmpstatbuf;
2891 if ((unix = tounixspec_ts(SvPV(libdir,len),Nullch)) != Nullch) {
2893 while (unix[len-1] == '/') len--; /* Cosmetic */
2894 sv_usepvn(libdir,unix,len);
2897 PerlIO_printf(PerlIO_stderr(),
2898 "Failed to unixify @INC element \"%s\"\n",
2901 /* .../archname/version if -d .../archname/version/auto */
2902 sv_setsv(subdir, libdir);
2903 sv_catpv(subdir, PL_archpat_auto);
2904 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2905 S_ISDIR(tmpstatbuf.st_mode))
2906 av_push(GvAVn(PL_incgv),
2907 newSVpvn(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2909 /* .../archname if -d .../archname/auto */
2910 sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
2911 strlen(PL_patchlevel) + 1, "", 0);
2912 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2913 S_ISDIR(tmpstatbuf.st_mode))
2914 av_push(GvAVn(PL_incgv),
2915 newSVpvn(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2918 /* finally push this lib directory on the end of @INC */
2919 av_push(GvAVn(PL_incgv), libdir);
2924 STATIC struct perl_thread *
2927 struct perl_thread *thr;
2930 Newz(53, thr, 1, struct perl_thread);
2931 PL_curcop = &PL_compiling;
2932 thr->cvcache = newHV();
2933 thr->threadsv = newAV();
2934 /* thr->threadsvp is set when find_threadsv is called */
2935 thr->specific = newAV();
2936 thr->errhv = newHV();
2937 thr->flags = THRf_R_JOINABLE;
2938 MUTEX_INIT(&thr->mutex);
2939 /* Handcraft thrsv similarly to mess_sv */
2940 New(53, PL_thrsv, 1, SV);
2941 Newz(53, xpv, 1, XPV);
2942 SvFLAGS(PL_thrsv) = SVt_PV;
2943 SvANY(PL_thrsv) = (void*)xpv;
2944 SvREFCNT(PL_thrsv) = 1 << 30; /* practically infinite */
2945 SvPVX(PL_thrsv) = (char*)thr;
2946 SvCUR_set(PL_thrsv, sizeof(thr));
2947 SvLEN_set(PL_thrsv, sizeof(thr));
2948 *SvEND(PL_thrsv) = '\0'; /* in the trailing_nul field */
2949 thr->oursv = PL_thrsv;
2950 PL_chopset = " \n-";
2953 MUTEX_LOCK(&PL_threads_mutex);
2958 MUTEX_UNLOCK(&PL_threads_mutex);
2960 #ifdef HAVE_THREAD_INTERN
2961 init_thread_intern(thr);
2964 #ifdef SET_THREAD_SELF
2965 SET_THREAD_SELF(thr);
2967 thr->self = pthread_self();
2968 #endif /* SET_THREAD_SELF */
2972 * These must come after the SET_THR because sv_setpvn does
2973 * SvTAINT and the taint fields require dTHR.
2975 PL_toptarget = NEWSV(0,0);
2976 sv_upgrade(PL_toptarget, SVt_PVFM);
2977 sv_setpvn(PL_toptarget, "", 0);
2978 PL_bodytarget = NEWSV(0,0);
2979 sv_upgrade(PL_bodytarget, SVt_PVFM);
2980 sv_setpvn(PL_bodytarget, "", 0);
2981 PL_formtarget = PL_bodytarget;
2982 thr->errsv = newSVpvn("", 0);
2983 (void) find_threadsv("@"); /* Ensure $@ is initialised early */
2986 PL_regcompp = FUNC_NAME_TO_PTR(pregcomp);
2987 PL_regexecp = FUNC_NAME_TO_PTR(regexec_flags);
2989 PL_reginterp_cnt = 0;
2993 #endif /* USE_THREADS */
2996 call_list(I32 oldscope, AV *paramList)
3000 line_t oldline = PL_curcop->cop_line;
3005 while (AvFILL(paramList) >= 0) {
3006 cv = (CV*)av_shift(paramList);
3008 CALLPROTECT(&ret, call_list_body, cv);
3011 (void)SvPV(atsv, len);
3013 PL_curcop = &PL_compiling;
3014 PL_curcop->cop_line = oldline;
3015 if (paramList == PL_beginav)
3016 sv_catpv(atsv, "BEGIN failed--compilation aborted");
3018 sv_catpv(atsv, "END failed--cleanup aborted");
3019 while (PL_scopestack_ix > oldscope)
3021 croak("%s", SvPVX(atsv));
3028 /* my_exit() was called */
3029 while (PL_scopestack_ix > oldscope)
3032 PL_curstash = PL_defstash;
3034 call_list(oldscope, PL_endav);
3035 PL_curcop = &PL_compiling;
3036 PL_curcop->cop_line = oldline;
3037 if (PL_statusvalue) {
3038 if (paramList == PL_beginav)
3039 croak("BEGIN failed--compilation aborted");
3041 croak("END failed--cleanup aborted");
3047 PL_curcop = &PL_compiling;
3048 PL_curcop->cop_line = oldline;
3051 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
3059 call_list_body(va_list args)
3062 CV *cv = va_arg(args, CV*);
3064 PUSHMARK(PL_stack_sp);
3065 perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
3074 DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
3075 thr, (unsigned long) status));
3084 STATUS_NATIVE_SET(status);
3091 my_failure_exit(void)
3094 if (vaxc$errno & 1) {
3095 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
3096 STATUS_NATIVE_SET(44);
3099 if (!vaxc$errno && errno) /* unlikely */
3100 STATUS_NATIVE_SET(44);
3102 STATUS_NATIVE_SET(vaxc$errno);
3107 STATUS_POSIX_SET(errno);
3109 exitstatus = STATUS_POSIX >> 8;
3110 if (exitstatus & 255)
3111 STATUS_POSIX_SET(exitstatus);
3113 STATUS_POSIX_SET(255);
3123 register PERL_CONTEXT *cx;
3128 SvREFCNT_dec(PL_e_script);
3129 PL_e_script = Nullsv;
3132 POPSTACK_TO(PL_mainstack);
3133 if (cxstack_ix >= 0) {
3136 POPBLOCK(cx,PL_curpm);
3145 #endif /* PERL_OBJECT */
3151 read_e_script(CPerlObj *pPerl, int idx, SV *buf_sv, int maxlen)
3153 read_e_script(int idx, SV *buf_sv, int maxlen)
3157 p = SvPVX(PL_e_script);
3158 nl = strchr(p, '\n');
3159 nl = (nl) ? nl+1 : SvEND(PL_e_script);
3161 filter_del(read_e_script);
3164 sv_catpvn(buf_sv, p, nl-p);
3165 sv_chop(PL_e_script, nl);