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;
634 typedef void (*xs_init_t)(CPerlObj*);
636 typedef void (*xs_init_t)(void);
641 perl_parse(xs_init_t xsinit, int argc, char **argv, char **env)
643 perl_parse(PerlInterpreter *sv_interp, xs_init_t xsinit, int argc, char **argv, char **env)
650 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
653 croak("suidperl is no longer needed since the kernel can now execute\n\
654 setuid perl scripts securely.\n");
659 if (!(PL_curinterp = sv_interp))
663 #if defined(__DYNAMIC__) && (defined(NeXT) || defined(__NeXT__))
664 _dyld_lookup_and_bind
665 ("__environ", (unsigned long *) &environ_pointer, NULL);
670 #ifndef VMS /* VMS doesn't have environ array */
671 PL_origenviron = environ;
676 /* Come here if running an undumped a.out. */
678 PL_origfilename = savepv(argv[0]);
679 PL_do_undump = FALSE;
680 cxstack_ix = -1; /* start label stack again */
682 init_postdump_symbols(argc,argv,env);
687 PL_curpad = AvARRAY(PL_comppad);
688 op_free(PL_main_root);
689 PL_main_root = Nullop;
691 PL_main_start = Nullop;
692 SvREFCNT_dec(PL_main_cv);
696 oldscope = PL_scopestack_ix;
697 PL_dowarn = G_WARN_OFF;
699 CALLPROTECT(&ret, FUNC_NAME_TO_PTR(perl_parse_body), env, xsinit);
707 /* my_exit() was called */
708 while (PL_scopestack_ix > oldscope)
711 PL_curstash = PL_defstash;
713 call_list(oldscope, PL_endav);
714 return STATUS_NATIVE_EXPORT;
716 PerlIO_printf(PerlIO_stderr(), "panic: top_env\n");
723 perl_parse_body(va_list args)
726 int argc = PL_origargc;
727 char **argv = PL_origargv;
728 char **env = va_arg(args, char**);
729 char *scriptname = NULL;
731 VOL bool dosearch = FALSE;
737 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, FUNC_NAME_TO_PTR(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 /* XXX this is probably not what they think they're getting.
1194 * It has the same effect as "sub name;", i.e. just a forward
1196 if (create && !GvCVu(gv))
1197 return newSUB(start_subparse(FALSE, 0),
1198 newSVOP(OP_CONST, 0, newSVpv(name,0)),
1206 /* Be sure to refetch the stack pointer after calling these routines. */
1209 perl_call_argv(const char *sub_name, I32 flags, register char **argv)
1211 /* See G_* flags in cop.h */
1212 /* null terminated arg list */
1219 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
1224 return perl_call_pv(sub_name, flags);
1228 perl_call_pv(const char *sub_name, I32 flags)
1229 /* name of the subroutine */
1230 /* See G_* flags in cop.h */
1232 return perl_call_sv((SV*)perl_get_cv(sub_name, TRUE), flags);
1236 perl_call_method(const char *methname, I32 flags)
1237 /* name of the subroutine */
1238 /* See G_* flags in cop.h */
1244 XPUSHs(sv_2mortal(newSVpv(methname,0)));
1249 return perl_call_sv(*PL_stack_sp--, flags);
1252 /* May be called with any of a CV, a GV, or an SV containing the name. */
1254 perl_call_sv(SV *sv, I32 flags)
1256 /* See G_* flags in cop.h */
1259 LOGOP myop; /* fake syntax tree node */
1263 bool oldcatch = CATCH_GET;
1267 if (flags & G_DISCARD) {
1272 Zero(&myop, 1, LOGOP);
1273 myop.op_next = Nullop;
1274 if (!(flags & G_NOARGS))
1275 myop.op_flags |= OPf_STACKED;
1276 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1277 (flags & G_ARRAY) ? OPf_WANT_LIST :
1282 EXTEND(PL_stack_sp, 1);
1283 *++PL_stack_sp = sv;
1285 oldscope = PL_scopestack_ix;
1287 if (PERLDB_SUB && PL_curstash != PL_debstash
1288 /* Handle first BEGIN of -d. */
1289 && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub)))
1290 /* Try harder, since this may have been a sighandler, thus
1291 * curstash may be meaningless. */
1292 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != PL_debstash)
1293 && !(flags & G_NODEBUG))
1294 PL_op->op_private |= OPpENTERSUB_DB;
1296 if (!(flags & G_EVAL)) {
1298 perl_call_xbody((OP*)&myop, FALSE);
1299 retval = PL_stack_sp - (PL_stack_base + oldmark);
1303 cLOGOP->op_other = PL_op;
1305 /* we're trying to emulate pp_entertry() here */
1307 register PERL_CONTEXT *cx;
1308 I32 gimme = GIMME_V;
1313 push_return(PL_op->op_next);
1314 PUSHBLOCK(cx, CXt_EVAL, PL_stack_sp);
1316 PL_eval_root = PL_op; /* Only needed so that goto works right. */
1318 PL_in_eval = EVAL_INEVAL;
1319 if (flags & G_KEEPERR)
1320 PL_in_eval |= EVAL_KEEPERR;
1327 CALLPROTECT(&ret, FUNC_NAME_TO_PTR(perl_call_body), (OP*)&myop, FALSE);
1330 retval = PL_stack_sp - (PL_stack_base + oldmark);
1331 if (!(flags & G_KEEPERR))
1338 /* my_exit() was called */
1339 PL_curstash = PL_defstash;
1342 croak("Callback called exit");
1347 PL_op = PL_restartop;
1351 PL_stack_sp = PL_stack_base + oldmark;
1352 if (flags & G_ARRAY)
1356 *++PL_stack_sp = &PL_sv_undef;
1361 if (PL_scopestack_ix > oldscope) {
1365 register PERL_CONTEXT *cx;
1376 if (flags & G_DISCARD) {
1377 PL_stack_sp = PL_stack_base + oldmark;
1387 perl_call_body(va_list args)
1389 OP *myop = va_arg(args, OP*);
1390 int is_eval = va_arg(args, int);
1392 perl_call_xbody(myop, is_eval);
1397 perl_call_xbody(OP *myop, int is_eval)
1401 if (PL_op == myop) {
1403 PL_op = pp_entereval(ARGS);
1405 PL_op = pp_entersub(ARGS);
1411 /* Eval a string. The G_EVAL flag is always assumed. */
1414 perl_eval_sv(SV *sv, I32 flags)
1416 /* See G_* flags in cop.h */
1419 UNOP myop; /* fake syntax tree node */
1420 I32 oldmark = SP - PL_stack_base;
1426 if (flags & G_DISCARD) {
1433 Zero(PL_op, 1, UNOP);
1434 EXTEND(PL_stack_sp, 1);
1435 *++PL_stack_sp = sv;
1436 oldscope = PL_scopestack_ix;
1438 if (!(flags & G_NOARGS))
1439 myop.op_flags = OPf_STACKED;
1440 myop.op_next = Nullop;
1441 myop.op_type = OP_ENTEREVAL;
1442 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1443 (flags & G_ARRAY) ? OPf_WANT_LIST :
1445 if (flags & G_KEEPERR)
1446 myop.op_flags |= OPf_SPECIAL;
1449 CALLPROTECT(&ret, FUNC_NAME_TO_PTR(perl_call_body), (OP*)&myop, TRUE);
1452 retval = PL_stack_sp - (PL_stack_base + oldmark);
1453 if (!(flags & G_KEEPERR))
1460 /* my_exit() was called */
1461 PL_curstash = PL_defstash;
1464 croak("Callback called exit");
1469 PL_op = PL_restartop;
1473 PL_stack_sp = PL_stack_base + oldmark;
1474 if (flags & G_ARRAY)
1478 *++PL_stack_sp = &PL_sv_undef;
1483 if (flags & G_DISCARD) {
1484 PL_stack_sp = PL_stack_base + oldmark;
1494 perl_eval_pv(const char *p, I32 croak_on_error)
1497 SV* sv = newSVpv(p, 0);
1500 perl_eval_sv(sv, G_SCALAR);
1507 if (croak_on_error && SvTRUE(ERRSV)) {
1509 croak(SvPVx(ERRSV, n_a));
1515 /* Require a module. */
1518 perl_require_pv(const char *pv)
1522 PUSHSTACKi(PERLSI_REQUIRE);
1524 sv = sv_newmortal();
1525 sv_setpv(sv, "require '");
1528 perl_eval_sv(sv, G_DISCARD);
1534 magicname(char *sym, char *name, I32 namlen)
1538 if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
1539 sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1543 usage(char *name) /* XXX move this out into a module ? */
1546 /* This message really ought to be max 23 lines.
1547 * Removed -h because the user already knows that opton. Others? */
1549 static char *usage_msg[] = {
1550 "-0[octal] specify record separator (\\0, if no argument)",
1551 "-a autosplit mode with -n or -p (splits $_ into @F)",
1552 "-c check syntax only (runs BEGIN and END blocks)",
1553 "-d[:debugger] run program under debugger",
1554 "-D[number/list] set debugging flags (argument is a bit mask or alphabets)",
1555 "-e 'command' one line of program (several -e's allowed, omit programfile)",
1556 "-F/pattern/ split() pattern for -a switch (//'s are optional)",
1557 "-i[extension] edit <> files in place (makes backup if extension supplied)",
1558 "-Idirectory specify @INC/#include directory (several -I's allowed)",
1559 "-l[octal] enable line ending processing, specifies line terminator",
1560 "-[mM][-]module execute `use/no module...' before executing program",
1561 "-n assume 'while (<>) { ... }' loop around program",
1562 "-p assume loop like -n but print line also, like sed",
1563 "-P run program through C preprocessor before compilation",
1564 "-s enable rudimentary parsing for switches after programfile",
1565 "-S look for programfile using PATH environment variable",
1566 "-T enable tainting checks",
1567 "-u dump core after parsing program",
1568 "-U allow unsafe operations",
1569 "-v print version, subversion (includes VERY IMPORTANT perl info)",
1570 "-V[:variable] print configuration summary (or a single Config.pm variable)",
1571 "-w enable many useful warnings (RECOMMENDED)",
1572 "-x[directory] strip off text before #!perl line and perhaps cd to directory",
1576 char **p = usage_msg;
1578 printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
1580 printf("\n %s", *p++);
1583 /* This routine handles any switches that can be given during run */
1586 moreswitches(char *s)
1595 rschar = scan_oct(s, 4, &numlen);
1596 SvREFCNT_dec(PL_nrs);
1597 if (rschar & ~((U8)~0))
1598 PL_nrs = &PL_sv_undef;
1599 else if (!rschar && numlen >= 2)
1600 PL_nrs = newSVpvn("", 0);
1603 PL_nrs = newSVpvn(&ch, 1);
1609 PL_splitstr = savepv(s + 1);
1623 if (*s == ':' || *s == '=') {
1624 my_setenv("PERL5DB", form("use Devel::%s;", ++s));
1628 PL_perldb = PERLDB_ALL;
1635 if (isALPHA(s[1])) {
1636 static char debopts[] = "psltocPmfrxuLHXDS";
1639 for (s++; *s && (d = strchr(debopts,*s)); s++)
1640 PL_debug |= 1 << (d - debopts);
1643 PL_debug = atoi(s+1);
1644 for (s++; isDIGIT(*s); s++) ;
1646 PL_debug |= 0x80000000;
1648 warn("Recompile perl with -DDEBUGGING to use -D switch\n");
1649 for (s++; isALNUM(*s); s++) ;
1654 usage(PL_origargv[0]);
1658 Safefree(PL_inplace);
1659 PL_inplace = savepv(s+1);
1661 for (s = PL_inplace; *s && !isSPACE(*s); s++) ;
1664 if (*s == '-') /* Additional switches on #! line. */
1668 case 'I': /* -I handled both here and in parse_perl() */
1671 while (*s && isSPACE(*s))
1675 for (e = s; *e && !isSPACE(*e); e++) ;
1676 p = savepvn(s, e-s);
1682 croak("No space allowed after -I");
1690 PL_ors = savepv("\n");
1692 *PL_ors = scan_oct(s, 3 + (*s == '0'), &numlen);
1697 if (RsPARA(PL_nrs)) {
1702 PL_ors = SvPV(PL_nrs, PL_orslen);
1703 PL_ors = savepvn(PL_ors, PL_orslen);
1707 forbid_setid("-M"); /* XXX ? */
1710 forbid_setid("-m"); /* XXX ? */
1715 /* -M-foo == 'no foo' */
1716 if (*s == '-') { use = "no "; ++s; }
1717 sv = newSVpv(use,0);
1719 /* We allow -M'Module qw(Foo Bar)' */
1720 while(isALNUM(*s) || *s==':') ++s;
1722 sv_catpv(sv, start);
1723 if (*(start-1) == 'm') {
1725 croak("Can't use '%c' after -mname", *s);
1726 sv_catpv( sv, " ()");
1729 sv_catpvn(sv, start, s-start);
1730 sv_catpv(sv, " split(/,/,q{");
1735 if (PL_preambleav == NULL)
1736 PL_preambleav = newAV();
1737 av_push(PL_preambleav, sv);
1740 croak("No space allowed after -%c", *(s-1));
1752 PL_doswitches = TRUE;
1757 croak("Too late for \"-T\" option");
1761 PL_do_undump = TRUE;
1769 #if defined(PERL_SUBVERSION) && PERL_SUBVERSION > 0
1770 printf("\nThis is perl, version %d.%03d_%02d built for %s",
1771 PERL_REVISION, PERL_VERSION, PERL_SUBVERSION, ARCHNAME);
1773 printf("\nThis is perl, version %s built for %s",
1774 PL_patchlevel, ARCHNAME);
1776 #if defined(LOCAL_PATCH_COUNT)
1777 if (LOCAL_PATCH_COUNT > 0)
1778 printf("\n(with %d registered patch%s, see perl -V for more detail)",
1779 LOCAL_PATCH_COUNT, (LOCAL_PATCH_COUNT!=1) ? "es" : "");
1782 printf("\n\nCopyright 1987-1999, Larry Wall\n");
1784 printf("\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
1787 printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
1788 printf("djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
1791 printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
1792 "Version 5 port Copyright (c) 1994-1999, Andreas Kaiser, Ilya Zakharevich\n");
1795 printf("atariST series port, ++jrb bammi@cadence.com\n");
1798 printf("BeOS port Copyright Tom Spindler, 1997-1999\n");
1801 printf("MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-1999\n");
1804 printf("MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
1807 printf("Stratus VOS port by Paul_Green@stratus.com, 1997-1999\n");
1810 printf("VM/ESA port by Neale Ferguson, 1998-1999\n");
1813 printf("BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
1816 printf("MiNT port by Guido Flohr, 1997-1999\n");
1818 #ifdef BINARY_BUILD_NOTICE
1819 BINARY_BUILD_NOTICE;
1822 Perl may be copied only under the terms of either the Artistic License or the\n\
1823 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n\
1824 Complete documentation for Perl, including FAQ lists, should be found on\n\
1825 this system using `man perl' or `perldoc perl'. If you have access to the\n\
1826 Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n");
1829 if (! (PL_dowarn & G_WARN_ALL_MASK))
1830 PL_dowarn |= G_WARN_ON;
1834 PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
1835 PL_compiling.cop_warnings = WARN_ALL ;
1839 PL_dowarn = G_WARN_ALL_OFF;
1840 PL_compiling.cop_warnings = WARN_NONE ;
1845 if (s[1] == '-') /* Additional switches on #! line. */
1850 #if defined(WIN32) || !defined(PERL_STRICT_CR)
1856 #ifdef ALTERNATE_SHEBANG
1857 case 'S': /* OS/2 needs -S on "extproc" line. */
1865 croak("Can't emulate -%.1s on #! line",s);
1870 /* compliments of Tom Christiansen */
1872 /* unexec() can be found in the Gnu emacs distribution */
1873 /* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
1884 prog = newSVpv(BIN_EXP, 0);
1885 sv_catpv(prog, "/perl");
1886 file = newSVpv(PL_origfilename, 0);
1887 sv_catpv(file, ".perldump");
1889 unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
1890 /* unexec prints msg to stderr in case of failure */
1891 PerlProc_exit(status);
1894 # include <lib$routines.h>
1895 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
1897 ABORT(); /* for use with undump */
1902 /* initialize curinterp */
1907 #ifdef PERL_OBJECT /* XXX kludge */
1910 PL_chopset = " \n-"; \
1911 PL_copline = NOLINE; \
1912 PL_curcop = &PL_compiling;\
1913 PL_curcopdb = NULL; \
1916 PL_dumpindent = 4; \
1917 PL_laststatval = -1; \
1918 PL_laststype = OP_STAT; \
1919 PL_maxscream = -1; \
1920 PL_maxsysfd = MAXSYSFD; \
1921 PL_statname = Nullsv; \
1922 PL_tmps_floor = -1; \
1924 PL_op_mask = NULL; \
1926 PL_laststatval = -1; \
1927 PL_laststype = OP_STAT; \
1928 PL_mess_sv = Nullsv; \
1929 PL_splitstr = " "; \
1930 PL_generation = 100; \
1931 PL_exitlist = NULL; \
1932 PL_exitlistlen = 0; \
1934 PL_in_clean_objs = FALSE; \
1935 PL_in_clean_all = FALSE; \
1936 PL_profiledata = NULL; \
1938 PL_rsfp_filters = Nullav; \
1943 # ifdef MULTIPLICITY
1944 # define PERLVAR(var,type)
1945 # define PERLVARI(var,type,init) PL_curinterp->var = init;
1946 # define PERLVARIC(var,type,init) PL_curinterp->var = init;
1947 # include "intrpvar.h"
1948 # ifndef USE_THREADS
1949 # include "thrdvar.h"
1955 # define PERLVAR(var,type)
1956 # define PERLVARI(var,type,init) PL_##var = init;
1957 # define PERLVARIC(var,type,init) PL_##var = init;
1958 # include "intrpvar.h"
1959 # ifndef USE_THREADS
1960 # include "thrdvar.h"
1971 init_main_stash(void)
1976 /* Note that strtab is a rather special HV. Assumptions are made
1977 about not iterating on it, and not adding tie magic to it.
1978 It is properly deallocated in perl_destruct() */
1979 PL_strtab = newHV();
1981 MUTEX_INIT(&PL_strtab_mutex);
1983 HvSHAREKEYS_off(PL_strtab); /* mandatory */
1984 hv_ksplit(PL_strtab, 512);
1986 PL_curstash = PL_defstash = newHV();
1987 PL_curstname = newSVpvn("main",4);
1988 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
1989 SvREFCNT_dec(GvHV(gv));
1990 GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);
1992 HvNAME(PL_defstash) = savepv("main");
1993 PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
1994 GvMULTI_on(PL_incgv);
1995 PL_hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */
1996 GvMULTI_on(PL_hintgv);
1997 PL_defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
1998 PL_errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
1999 GvMULTI_on(PL_errgv);
2000 PL_replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */
2001 GvMULTI_on(PL_replgv);
2002 (void)form("%240s",""); /* Preallocate temp - for immediate signals. */
2003 sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
2004 sv_setpvn(ERRSV, "", 0);
2005 PL_curstash = PL_defstash;
2006 PL_compiling.cop_stash = PL_defstash;
2007 PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
2008 PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
2009 /* We must init $/ before switches are processed. */
2010 sv_setpvn(perl_get_sv("/", TRUE), "\n", 1);
2014 open_script(char *scriptname, bool dosearch, SV *sv, int *fdscript)
2022 PL_origfilename = savepv("-e");
2025 /* if find_script() returns, it returns a malloc()-ed value */
2026 PL_origfilename = scriptname = find_script(scriptname, dosearch, NULL, 1);
2028 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
2029 char *s = scriptname + 8;
2030 *fdscript = atoi(s);
2034 scriptname = savepv(s + 1);
2035 Safefree(PL_origfilename);
2036 PL_origfilename = scriptname;
2041 PL_curcop->cop_filegv = gv_fetchfile(PL_origfilename);
2042 if (strEQ(PL_origfilename,"-"))
2044 if (*fdscript >= 0) {
2045 PL_rsfp = PerlIO_fdopen(*fdscript,PERL_SCRIPT_MODE);
2046 #if defined(HAS_FCNTL) && defined(F_SETFD)
2048 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1); /* ensure close-on-exec */
2051 else if (PL_preprocess) {
2052 char *cpp_cfg = CPPSTDIN;
2053 SV *cpp = newSVpvn("",0);
2054 SV *cmd = NEWSV(0,0);
2056 if (strEQ(cpp_cfg, "cppstdin"))
2057 sv_catpvf(cpp, "%s/", BIN_EXP);
2058 sv_catpv(cpp, cpp_cfg);
2061 sv_catpv(sv,PRIVLIB_EXP);
2065 sed %s -e \"/^[^#]/b\" \
2066 -e \"/^#[ ]*include[ ]/b\" \
2067 -e \"/^#[ ]*define[ ]/b\" \
2068 -e \"/^#[ ]*if[ ]/b\" \
2069 -e \"/^#[ ]*ifdef[ ]/b\" \
2070 -e \"/^#[ ]*ifndef[ ]/b\" \
2071 -e \"/^#[ ]*else/b\" \
2072 -e \"/^#[ ]*elif[ ]/b\" \
2073 -e \"/^#[ ]*undef[ ]/b\" \
2074 -e \"/^#[ ]*endif/b\" \
2077 (PL_doextract ? "-e \"1,/^#/d\n\"" : ""),
2081 %s %s -e '/^[^#]/b' \
2082 -e '/^#[ ]*include[ ]/b' \
2083 -e '/^#[ ]*define[ ]/b' \
2084 -e '/^#[ ]*if[ ]/b' \
2085 -e '/^#[ ]*ifdef[ ]/b' \
2086 -e '/^#[ ]*ifndef[ ]/b' \
2087 -e '/^#[ ]*else/b' \
2088 -e '/^#[ ]*elif[ ]/b' \
2089 -e '/^#[ ]*undef[ ]/b' \
2090 -e '/^#[ ]*endif/b' \
2095 %s %s -e '/^[^#]/b' \
2096 -e '/^#[ ]*include[ ]/b' \
2097 -e '/^#[ ]*define[ ]/b' \
2098 -e '/^#[ ]*if[ ]/b' \
2099 -e '/^#[ ]*ifdef[ ]/b' \
2100 -e '/^#[ ]*ifndef[ ]/b' \
2101 -e '/^#[ ]*else/b' \
2102 -e '/^#[ ]*elif[ ]/b' \
2103 -e '/^#[ ]*undef[ ]/b' \
2104 -e '/^#[ ]*endif/b' \
2113 (PL_doextract ? "-e '1,/^#/d\n'" : ""),
2115 scriptname, cpp, sv, CPPMINUS);
2116 PL_doextract = FALSE;
2117 #ifdef IAMSUID /* actually, this is caught earlier */
2118 if (PL_euid != PL_uid && !PL_euid) { /* if running suidperl */
2120 (void)seteuid(PL_uid); /* musn't stay setuid root */
2123 (void)setreuid((Uid_t)-1, PL_uid);
2125 #ifdef HAS_SETRESUID
2126 (void)setresuid((Uid_t)-1, PL_uid, (Uid_t)-1);
2128 PerlProc_setuid(PL_uid);
2132 if (PerlProc_geteuid() != PL_uid)
2133 croak("Can't do seteuid!\n");
2135 #endif /* IAMSUID */
2136 PL_rsfp = PerlProc_popen(SvPVX(cmd), "r");
2140 else if (!*scriptname) {
2141 forbid_setid("program input from stdin");
2142 PL_rsfp = PerlIO_stdin();
2145 PL_rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
2146 #if defined(HAS_FCNTL) && defined(F_SETFD)
2148 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1); /* ensure close-on-exec */
2153 #ifndef IAMSUID /* in case script is not readable before setuid */
2155 PerlLIO_stat(SvPVX(GvSV(PL_curcop->cop_filegv)),&PL_statbuf) >= 0 &&
2156 PL_statbuf.st_mode & (S_ISUID|S_ISGID))
2159 PerlProc_execv(form("%s/sperl%s", BIN_EXP, PL_patchlevel), PL_origargv);
2160 croak("Can't do setuid\n");
2164 croak("Can't open perl script \"%s\": %s\n",
2165 SvPVX(GvSV(PL_curcop->cop_filegv)), Strerror(errno));
2170 * I_SYSSTATVFS HAS_FSTATVFS
2172 * I_STATFS HAS_FSTATFS
2173 * I_MNTENT HAS_GETMNTENT HAS_HASMNTOPT
2174 * here so that metaconfig picks them up. */
2178 fd_on_nosuid_fs(int fd)
2183 * Preferred order: fstatvfs(), fstatfs(), getmntent().
2184 * fstatvfs() is UNIX98.
2186 * getmntent() is O(number-of-mounted-filesystems) and can hang.
2189 # ifdef HAS_FSTATVFS
2190 struct statvfs stfs;
2191 check_okay = fstatvfs(fd, &stfs) == 0;
2192 on_nosuid = check_okay && (stfs.f_flag & ST_NOSUID);
2194 # if defined(HAS_FSTATFS) && defined(HAS_STRUCT_STATFS_FLAGS)
2196 check_okay = fstatfs(fd, &stfs) == 0;
2197 # undef PERL_MOUNT_NOSUID
2198 # if !defined(PERL_MOUNT_NOSUID) && defined(MNT_NOSUID)
2199 # define PERL_MOUNT_NOSUID MNT_NOSUID
2201 # if !defined(PERL_MOUNT_NOSUID) && defined(MS_NOSUID)
2202 # define PERL_MOUNT_NOSUID MS_NOSUID
2204 # if !defined(PERL_MOUNT_NOSUID) && defined(M_NOSUID)
2205 # define PERL_MOUNT_NOSUID M_NOSUID
2207 # ifdef PERL_MOUNT_NOSUID
2208 on_nosuid = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID);
2211 # if defined(HAS_GETMNTENT) && defined(HAS_HASMNTOPT) && defined(MNTOPT_NOSUID)
2212 FILE *mtab = fopen("/etc/mtab", "r");
2213 struct mntent *entry;
2214 struct stat stb, fsb;
2216 if (mtab && (fstat(fd, &stb) == 0)) {
2217 while (entry = getmntent(mtab)) {
2218 if (stat(entry->mnt_dir, &fsb) == 0
2219 && fsb.st_dev == stb.st_dev)
2221 /* found the filesystem */
2223 if (hasmntopt(entry, MNTOPT_NOSUID))
2226 } /* A single fs may well fail its stat(). */
2231 # endif /* mntent */
2232 # endif /* statfs */
2233 # endif /* statvfs */
2235 croak("Can't check filesystem of script \"%s\"", PL_origfilename);
2238 #endif /* IAMSUID */
2241 validate_suid(char *validarg, char *scriptname, int fdscript)
2245 /* do we need to emulate setuid on scripts? */
2247 /* This code is for those BSD systems that have setuid #! scripts disabled
2248 * in the kernel because of a security problem. Merely defining DOSUID
2249 * in perl will not fix that problem, but if you have disabled setuid
2250 * scripts in the kernel, this will attempt to emulate setuid and setgid
2251 * on scripts that have those now-otherwise-useless bits set. The setuid
2252 * root version must be called suidperl or sperlN.NNN. If regular perl
2253 * discovers that it has opened a setuid script, it calls suidperl with
2254 * the same argv that it had. If suidperl finds that the script it has
2255 * just opened is NOT setuid root, it sets the effective uid back to the
2256 * uid. We don't just make perl setuid root because that loses the
2257 * effective uid we had before invoking perl, if it was different from the
2260 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
2261 * be defined in suidperl only. suidperl must be setuid root. The
2262 * Configure script will set this up for you if you want it.
2269 if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0) /* normal stat is insecure */
2270 croak("Can't stat script \"%s\"",PL_origfilename);
2271 if (fdscript < 0 && PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
2276 #ifndef HAS_SETREUID
2277 /* On this access check to make sure the directories are readable,
2278 * there is actually a small window that the user could use to make
2279 * filename point to an accessible directory. So there is a faint
2280 * chance that someone could execute a setuid script down in a
2281 * non-accessible directory. I don't know what to do about that.
2282 * But I don't think it's too important. The manual lies when
2283 * it says access() is useful in setuid programs.
2285 if (PerlLIO_access(SvPVX(GvSV(PL_curcop->cop_filegv)),1)) /*double check*/
2286 croak("Permission denied");
2288 /* If we can swap euid and uid, then we can determine access rights
2289 * with a simple stat of the file, and then compare device and
2290 * inode to make sure we did stat() on the same file we opened.
2291 * Then we just have to make sure he or she can execute it.
2294 struct stat tmpstatbuf;
2298 setreuid(PL_euid,PL_uid) < 0
2301 setresuid(PL_euid,PL_uid,(Uid_t)-1) < 0
2304 || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
2305 croak("Can't swap uid and euid"); /* really paranoid */
2306 if (PerlLIO_stat(SvPVX(GvSV(PL_curcop->cop_filegv)),&tmpstatbuf) < 0)
2307 croak("Permission denied"); /* testing full pathname here */
2308 #if defined(IAMSUID) && !defined(NO_NOSUID_CHECK)
2309 if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp)))
2310 croak("Permission denied");
2312 if (tmpstatbuf.st_dev != PL_statbuf.st_dev ||
2313 tmpstatbuf.st_ino != PL_statbuf.st_ino) {
2314 (void)PerlIO_close(PL_rsfp);
2315 if (PL_rsfp = PerlProc_popen("/bin/mail root","w")) { /* heh, heh */
2316 PerlIO_printf(PL_rsfp,
2317 "User %ld tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
2318 (Filename of set-id script was %s, uid %ld gid %ld.)\n\nSincerely,\nperl\n",
2319 (long)PL_uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
2320 (long)PL_statbuf.st_dev, (long)PL_statbuf.st_ino,
2321 SvPVX(GvSV(PL_curcop->cop_filegv)),
2322 (long)PL_statbuf.st_uid, (long)PL_statbuf.st_gid);
2323 (void)PerlProc_pclose(PL_rsfp);
2325 croak("Permission denied\n");
2329 setreuid(PL_uid,PL_euid) < 0
2331 # if defined(HAS_SETRESUID)
2332 setresuid(PL_uid,PL_euid,(Uid_t)-1) < 0
2335 || PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid)
2336 croak("Can't reswap uid and euid");
2337 if (!cando(S_IXUSR,FALSE,&PL_statbuf)) /* can real uid exec? */
2338 croak("Permission denied\n");
2340 #endif /* HAS_SETREUID */
2341 #endif /* IAMSUID */
2343 if (!S_ISREG(PL_statbuf.st_mode))
2344 croak("Permission denied");
2345 if (PL_statbuf.st_mode & S_IWOTH)
2346 croak("Setuid/gid script is writable by world");
2347 PL_doswitches = FALSE; /* -s is insecure in suid */
2348 PL_curcop->cop_line++;
2349 if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch ||
2350 strnNE(SvPV(PL_linestr,n_a),"#!",2) ) /* required even on Sys V */
2351 croak("No #! line");
2352 s = SvPV(PL_linestr,n_a)+2;
2354 while (!isSPACE(*s)) s++;
2355 for (s2 = s; (s2 > SvPV(PL_linestr,n_a)+2 &&
2356 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
2357 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
2358 croak("Not a perl script");
2359 while (*s == ' ' || *s == '\t') s++;
2361 * #! arg must be what we saw above. They can invoke it by
2362 * mentioning suidperl explicitly, but they may not add any strange
2363 * arguments beyond what #! says if they do invoke suidperl that way.
2365 len = strlen(validarg);
2366 if (strEQ(validarg," PHOOEY ") ||
2367 strnNE(s,validarg,len) || !isSPACE(s[len]))
2368 croak("Args must match #! line");
2371 if (PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
2372 PL_euid == PL_statbuf.st_uid)
2374 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2375 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2376 #endif /* IAMSUID */
2378 if (PL_euid) { /* oops, we're not the setuid root perl */
2379 (void)PerlIO_close(PL_rsfp);
2382 PerlProc_execv(form("%s/sperl%s", BIN_EXP, PL_patchlevel), PL_origargv);
2384 croak("Can't do setuid\n");
2387 if (PL_statbuf.st_mode & S_ISGID && PL_statbuf.st_gid != PL_egid) {
2389 (void)setegid(PL_statbuf.st_gid);
2392 (void)setregid((Gid_t)-1,PL_statbuf.st_gid);
2394 #ifdef HAS_SETRESGID
2395 (void)setresgid((Gid_t)-1,PL_statbuf.st_gid,(Gid_t)-1);
2397 PerlProc_setgid(PL_statbuf.st_gid);
2401 if (PerlProc_getegid() != PL_statbuf.st_gid)
2402 croak("Can't do setegid!\n");
2404 if (PL_statbuf.st_mode & S_ISUID) {
2405 if (PL_statbuf.st_uid != PL_euid)
2407 (void)seteuid(PL_statbuf.st_uid); /* all that for this */
2410 (void)setreuid((Uid_t)-1,PL_statbuf.st_uid);
2412 #ifdef HAS_SETRESUID
2413 (void)setresuid((Uid_t)-1,PL_statbuf.st_uid,(Uid_t)-1);
2415 PerlProc_setuid(PL_statbuf.st_uid);
2419 if (PerlProc_geteuid() != PL_statbuf.st_uid)
2420 croak("Can't do seteuid!\n");
2422 else if (PL_uid) { /* oops, mustn't run as root */
2424 (void)seteuid((Uid_t)PL_uid);
2427 (void)setreuid((Uid_t)-1,(Uid_t)PL_uid);
2429 #ifdef HAS_SETRESUID
2430 (void)setresuid((Uid_t)-1,(Uid_t)PL_uid,(Uid_t)-1);
2432 PerlProc_setuid((Uid_t)PL_uid);
2436 if (PerlProc_geteuid() != PL_uid)
2437 croak("Can't do seteuid!\n");
2440 if (!cando(S_IXUSR,TRUE,&PL_statbuf))
2441 croak("Permission denied\n"); /* they can't do this */
2444 else if (PL_preprocess)
2445 croak("-P not allowed for setuid/setgid script\n");
2446 else if (fdscript >= 0)
2447 croak("fd script not allowed in suidperl\n");
2449 croak("Script is not setuid/setgid in suidperl\n");
2451 /* We absolutely must clear out any saved ids here, so we */
2452 /* exec the real perl, substituting fd script for scriptname. */
2453 /* (We pass script name as "subdir" of fd, which perl will grok.) */
2454 PerlIO_rewind(PL_rsfp);
2455 PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0); /* just in case rewind didn't */
2456 for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;
2457 if (!PL_origargv[which])
2458 croak("Permission denied");
2459 PL_origargv[which] = savepv(form("/dev/fd/%d/%s",
2460 PerlIO_fileno(PL_rsfp), PL_origargv[which]));
2461 #if defined(HAS_FCNTL) && defined(F_SETFD)
2462 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0); /* ensure no close-on-exec */
2464 PerlProc_execv(form("%s/perl%s", BIN_EXP, PL_patchlevel), PL_origargv);/* try again */
2465 croak("Can't do setuid\n");
2466 #endif /* IAMSUID */
2468 if (PL_euid != PL_uid || PL_egid != PL_gid) { /* (suidperl doesn't exist, in fact) */
2469 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
2471 PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf); /* may be either wrapped or real suid */
2472 if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
2474 (PL_egid != PL_gid && PL_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
2477 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
2478 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2479 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
2480 /* not set-id, must be wrapped */
2486 find_beginning(void)
2488 register char *s, *s2;
2490 /* skip forward in input to the real script? */
2493 while (PL_doextract) {
2494 if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch)
2495 croak("No Perl script found in input\n");
2496 if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
2497 PerlIO_ungetc(PL_rsfp, '\n'); /* to keep line count right */
2498 PL_doextract = FALSE;
2499 while (*s && !(isSPACE (*s) || *s == '#')) s++;
2501 while (*s == ' ' || *s == '\t') s++;
2503 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2504 if (strnEQ(s2-4,"perl",4))
2506 while (s = moreswitches(s)) ;
2508 if (PL_cddir && PerlDir_chdir(PL_cddir) < 0)
2509 croak("Can't chdir to %s",PL_cddir);
2518 PL_uid = (int)PerlProc_getuid();
2519 PL_euid = (int)PerlProc_geteuid();
2520 PL_gid = (int)PerlProc_getgid();
2521 PL_egid = (int)PerlProc_getegid();
2523 PL_uid |= PL_gid << 16;
2524 PL_euid |= PL_egid << 16;
2526 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
2530 forbid_setid(char *s)
2532 if (PL_euid != PL_uid)
2533 croak("No %s allowed while running setuid", s);
2534 if (PL_egid != PL_gid)
2535 croak("No %s allowed while running setgid", s);
2542 PL_curstash = PL_debstash;
2543 PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2544 AvREAL_off(PL_dbargs);
2545 PL_DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2546 PL_DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2547 PL_DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
2548 PL_DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2549 sv_setiv(PL_DBsingle, 0);
2550 PL_DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2551 sv_setiv(PL_DBtrace, 0);
2552 PL_DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2553 sv_setiv(PL_DBsignal, 0);
2554 PL_curstash = PL_defstash;
2557 #ifndef STRESS_REALLOC
2558 #define REASONABLE(size) (size)
2560 #define REASONABLE(size) (1) /* unreasonable */
2564 init_stacks(ARGSproto)
2566 /* start with 128-item stack and 8K cxstack */
2567 PL_curstackinfo = new_stackinfo(REASONABLE(128),
2568 REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
2569 PL_curstackinfo->si_type = PERLSI_MAIN;
2570 PL_curstack = PL_curstackinfo->si_stack;
2571 PL_mainstack = PL_curstack; /* remember in case we switch stacks */
2573 PL_stack_base = AvARRAY(PL_curstack);
2574 PL_stack_sp = PL_stack_base;
2575 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
2577 New(50,PL_tmps_stack,REASONABLE(128),SV*);
2580 PL_tmps_max = REASONABLE(128);
2582 New(54,PL_markstack,REASONABLE(32),I32);
2583 PL_markstack_ptr = PL_markstack;
2584 PL_markstack_max = PL_markstack + REASONABLE(32);
2588 New(54,PL_scopestack,REASONABLE(32),I32);
2589 PL_scopestack_ix = 0;
2590 PL_scopestack_max = REASONABLE(32);
2592 New(54,PL_savestack,REASONABLE(128),ANY);
2593 PL_savestack_ix = 0;
2594 PL_savestack_max = REASONABLE(128);
2596 New(54,PL_retstack,REASONABLE(16),OP*);
2598 PL_retstack_max = REASONABLE(16);
2607 while (PL_curstackinfo->si_next)
2608 PL_curstackinfo = PL_curstackinfo->si_next;
2609 while (PL_curstackinfo) {
2610 PERL_SI *p = PL_curstackinfo->si_prev;
2611 /* curstackinfo->si_stack got nuked by sv_free_arenas() */
2612 Safefree(PL_curstackinfo->si_cxstack);
2613 Safefree(PL_curstackinfo);
2614 PL_curstackinfo = p;
2616 Safefree(PL_tmps_stack);
2617 Safefree(PL_markstack);
2618 Safefree(PL_scopestack);
2619 Safefree(PL_savestack);
2620 Safefree(PL_retstack);
2622 Safefree(PL_debname);
2623 Safefree(PL_debdelim);
2628 static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
2639 lex_start(PL_linestr);
2641 PL_subname = newSVpvn("main",4);
2645 init_predump_symbols(void)
2651 sv_setpvn(perl_get_sv("\"", TRUE), " ", 1);
2652 PL_stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2653 GvMULTI_on(PL_stdingv);
2654 IoIFP(GvIOp(PL_stdingv)) = PerlIO_stdin();
2655 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
2657 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(PL_stdingv));
2659 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
2661 IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = PerlIO_stdout();
2663 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
2665 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(PL_defoutgv));
2667 othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2668 GvMULTI_on(othergv);
2669 IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = PerlIO_stderr();
2670 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
2672 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv));
2674 PL_statname = NEWSV(66,0); /* last filename we did stat on */
2677 PL_osname = savepv(OSNAME);
2681 init_postdump_symbols(register int argc, register char **argv, register char **env)
2688 argc--,argv++; /* skip name of script */
2689 if (PL_doswitches) {
2690 for (; argc > 0 && **argv == '-'; argc--,argv++) {
2693 if (argv[0][1] == '-') {
2697 if (s = strchr(argv[0], '=')) {
2699 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
2702 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
2705 PL_toptarget = NEWSV(0,0);
2706 sv_upgrade(PL_toptarget, SVt_PVFM);
2707 sv_setpvn(PL_toptarget, "", 0);
2708 PL_bodytarget = NEWSV(0,0);
2709 sv_upgrade(PL_bodytarget, SVt_PVFM);
2710 sv_setpvn(PL_bodytarget, "", 0);
2711 PL_formtarget = PL_bodytarget;
2714 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
2715 sv_setpv(GvSV(tmpgv),PL_origfilename);
2716 magicname("0", "0", 1);
2718 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
2719 sv_setpv(GvSV(tmpgv),PL_origargv[0]);
2720 if (PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2721 GvMULTI_on(PL_argvgv);
2722 (void)gv_AVadd(PL_argvgv);
2723 av_clear(GvAVn(PL_argvgv));
2724 for (; argc > 0; argc--,argv++) {
2725 av_push(GvAVn(PL_argvgv),newSVpv(argv[0],0));
2728 if (PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
2730 GvMULTI_on(PL_envgv);
2731 hv = GvHVn(PL_envgv);
2732 hv_magic(hv, PL_envgv, 'E');
2733 #ifndef VMS /* VMS doesn't have environ array */
2734 /* Note that if the supplied env parameter is actually a copy
2735 of the global environ then it may now point to free'd memory
2736 if the environment has been modified since. To avoid this
2737 problem we treat env==NULL as meaning 'use the default'
2742 environ[0] = Nullch;
2743 for (; *env; env++) {
2744 if (!(s = strchr(*env,'=')))
2750 sv = newSVpv(s--,0);
2751 (void)hv_store(hv, *env, s - *env, sv, 0);
2753 #if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV)
2754 /* Sins of the RTL. See note in my_setenv(). */
2755 (void)PerlEnv_putenv(savepv(*env));
2759 #ifdef DYNAMIC_ENV_FETCH
2760 HvNAME(hv) = savepv(ENV_HV_NAME);
2764 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
2765 sv_setiv(GvSV(tmpgv), (IV)getpid());
2774 s = PerlEnv_getenv("PERL5LIB");
2778 incpush(PerlEnv_getenv("PERLLIB"), FALSE);
2780 /* Treat PERL5?LIB as a possible search list logical name -- the
2781 * "natural" VMS idiom for a Unix path string. We allow each
2782 * element to be a set of |-separated directories for compatibility.
2786 if (my_trnlnm("PERL5LIB",buf,0))
2787 do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
2789 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
2793 /* Use the ~-expanded versions of APPLLIB (undocumented),
2794 ARCHLIB PRIVLIB SITEARCH and SITELIB
2797 incpush(APPLLIB_EXP, TRUE);
2801 incpush(ARCHLIB_EXP, FALSE);
2804 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2807 incpush(PRIVLIB_EXP, TRUE);
2809 incpush(PRIVLIB_EXP, FALSE);
2813 incpush(SITEARCH_EXP, FALSE);
2817 incpush(SITELIB_EXP, TRUE);
2819 incpush(SITELIB_EXP, FALSE);
2823 incpush(".", FALSE);
2827 # define PERLLIB_SEP ';'
2830 # define PERLLIB_SEP '|'
2832 # define PERLLIB_SEP ':'
2835 #ifndef PERLLIB_MANGLE
2836 # define PERLLIB_MANGLE(s,n) (s)
2840 incpush(char *p, int addsubdirs)
2842 SV *subdir = Nullsv;
2848 subdir = sv_newmortal();
2849 if (!PL_archpat_auto) {
2850 STRLEN len = (sizeof(ARCHNAME) + strlen(PL_patchlevel)
2851 + sizeof("//auto"));
2852 New(55, PL_archpat_auto, len, char);
2853 sprintf(PL_archpat_auto, "/%s/%s/auto", ARCHNAME, PL_patchlevel);
2855 for (len = sizeof(ARCHNAME) + 2;
2856 PL_archpat_auto[len] != '\0' && PL_archpat_auto[len] != '/'; len++)
2857 if (PL_archpat_auto[len] == '.') PL_archpat_auto[len] = '_';
2862 /* Break at all separators */
2864 SV *libdir = NEWSV(55,0);
2867 /* skip any consecutive separators */
2868 while ( *p == PERLLIB_SEP ) {
2869 /* Uncomment the next line for PATH semantics */
2870 /* av_push(GvAVn(PL_incgv), newSVpvn(".", 1)); */
2874 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
2875 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
2880 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
2881 p = Nullch; /* break out */
2885 * BEFORE pushing libdir onto @INC we may first push version- and
2886 * archname-specific sub-directories.
2889 struct stat tmpstatbuf;
2894 if ((unix = tounixspec_ts(SvPV(libdir,len),Nullch)) != Nullch) {
2896 while (unix[len-1] == '/') len--; /* Cosmetic */
2897 sv_usepvn(libdir,unix,len);
2900 PerlIO_printf(PerlIO_stderr(),
2901 "Failed to unixify @INC element \"%s\"\n",
2904 /* .../archname/version if -d .../archname/version/auto */
2905 sv_setsv(subdir, libdir);
2906 sv_catpv(subdir, PL_archpat_auto);
2907 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2908 S_ISDIR(tmpstatbuf.st_mode))
2909 av_push(GvAVn(PL_incgv),
2910 newSVpvn(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2912 /* .../archname if -d .../archname/auto */
2913 sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
2914 strlen(PL_patchlevel) + 1, "", 0);
2915 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
2916 S_ISDIR(tmpstatbuf.st_mode))
2917 av_push(GvAVn(PL_incgv),
2918 newSVpvn(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
2921 /* finally push this lib directory on the end of @INC */
2922 av_push(GvAVn(PL_incgv), libdir);
2927 STATIC struct perl_thread *
2930 struct perl_thread *thr;
2933 Newz(53, thr, 1, struct perl_thread);
2934 PL_curcop = &PL_compiling;
2935 thr->cvcache = newHV();
2936 thr->threadsv = newAV();
2937 /* thr->threadsvp is set when find_threadsv is called */
2938 thr->specific = newAV();
2939 thr->errhv = newHV();
2940 thr->flags = THRf_R_JOINABLE;
2941 MUTEX_INIT(&thr->mutex);
2942 /* Handcraft thrsv similarly to mess_sv */
2943 New(53, PL_thrsv, 1, SV);
2944 Newz(53, xpv, 1, XPV);
2945 SvFLAGS(PL_thrsv) = SVt_PV;
2946 SvANY(PL_thrsv) = (void*)xpv;
2947 SvREFCNT(PL_thrsv) = 1 << 30; /* practically infinite */
2948 SvPVX(PL_thrsv) = (char*)thr;
2949 SvCUR_set(PL_thrsv, sizeof(thr));
2950 SvLEN_set(PL_thrsv, sizeof(thr));
2951 *SvEND(PL_thrsv) = '\0'; /* in the trailing_nul field */
2952 thr->oursv = PL_thrsv;
2953 PL_chopset = " \n-";
2956 MUTEX_LOCK(&PL_threads_mutex);
2961 MUTEX_UNLOCK(&PL_threads_mutex);
2963 #ifdef HAVE_THREAD_INTERN
2964 init_thread_intern(thr);
2967 #ifdef SET_THREAD_SELF
2968 SET_THREAD_SELF(thr);
2970 thr->self = pthread_self();
2971 #endif /* SET_THREAD_SELF */
2975 * These must come after the SET_THR because sv_setpvn does
2976 * SvTAINT and the taint fields require dTHR.
2978 PL_toptarget = NEWSV(0,0);
2979 sv_upgrade(PL_toptarget, SVt_PVFM);
2980 sv_setpvn(PL_toptarget, "", 0);
2981 PL_bodytarget = NEWSV(0,0);
2982 sv_upgrade(PL_bodytarget, SVt_PVFM);
2983 sv_setpvn(PL_bodytarget, "", 0);
2984 PL_formtarget = PL_bodytarget;
2985 thr->errsv = newSVpvn("", 0);
2986 (void) find_threadsv("@"); /* Ensure $@ is initialised early */
2989 PL_regcompp = FUNC_NAME_TO_PTR(pregcomp);
2990 PL_regexecp = FUNC_NAME_TO_PTR(regexec_flags);
2992 PL_reginterp_cnt = 0;
2996 #endif /* USE_THREADS */
2999 call_list(I32 oldscope, AV *paramList)
3003 line_t oldline = PL_curcop->cop_line;
3008 while (AvFILL(paramList) >= 0) {
3009 cv = (CV*)av_shift(paramList);
3011 CALLPROTECT(&ret, FUNC_NAME_TO_PTR(call_list_body), cv);
3014 (void)SvPV(atsv, len);
3016 PL_curcop = &PL_compiling;
3017 PL_curcop->cop_line = oldline;
3018 if (paramList == PL_beginav)
3019 sv_catpv(atsv, "BEGIN failed--compilation aborted");
3021 sv_catpv(atsv, "END failed--cleanup aborted");
3022 while (PL_scopestack_ix > oldscope)
3024 croak("%s", SvPVX(atsv));
3031 /* my_exit() was called */
3032 while (PL_scopestack_ix > oldscope)
3035 PL_curstash = PL_defstash;
3037 call_list(oldscope, PL_endav);
3038 PL_curcop = &PL_compiling;
3039 PL_curcop->cop_line = oldline;
3040 if (PL_statusvalue) {
3041 if (paramList == PL_beginav)
3042 croak("BEGIN failed--compilation aborted");
3044 croak("END failed--cleanup aborted");
3050 PL_curcop = &PL_compiling;
3051 PL_curcop->cop_line = oldline;
3054 PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
3062 call_list_body(va_list args)
3065 CV *cv = va_arg(args, CV*);
3067 PUSHMARK(PL_stack_sp);
3068 perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
3077 DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
3078 thr, (unsigned long) status));
3087 STATUS_NATIVE_SET(status);
3094 my_failure_exit(void)
3097 if (vaxc$errno & 1) {
3098 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
3099 STATUS_NATIVE_SET(44);
3102 if (!vaxc$errno && errno) /* unlikely */
3103 STATUS_NATIVE_SET(44);
3105 STATUS_NATIVE_SET(vaxc$errno);
3110 STATUS_POSIX_SET(errno);
3112 exitstatus = STATUS_POSIX >> 8;
3113 if (exitstatus & 255)
3114 STATUS_POSIX_SET(exitstatus);
3116 STATUS_POSIX_SET(255);
3126 register PERL_CONTEXT *cx;
3131 SvREFCNT_dec(PL_e_script);
3132 PL_e_script = Nullsv;
3135 POPSTACK_TO(PL_mainstack);
3136 if (cxstack_ix >= 0) {
3139 POPBLOCK(cx,PL_curpm);
3148 #endif /* PERL_OBJECT */
3154 read_e_script(CPerlObj *pPerl, int idx, SV *buf_sv, int maxlen)
3156 read_e_script(int idx, SV *buf_sv, int maxlen)
3160 p = SvPVX(PL_e_script);
3161 nl = strchr(p, '\n');
3162 nl = (nl) ? nl+1 : SvEND(PL_e_script);
3164 filter_del(read_e_script);
3167 sv_catpvn(buf_sv, p, nl-p);
3168 sv_chop(PL_e_script, nl);