This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
https://perl5.git.perl.org / perl5.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
win32 internal data must be interpreter-local
[perl5.git] / perl.c
CommitLineData
a0d0e21e
LW		 1/* perl.c
2 *
4eb8286e 3 * Copyright (c) 1987-1999 Larry Wall
a687059c 4 *
352d5a3a
LW		 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.
a687059c 7 *
8d063cd8
LW		 8 */
9
a0d0e21e
LW		 10/*
11 * "A ship then new they built for him/of mithril and of elven glass" --Bilbo
12 */
45d8adaa 13
378cc40b 14#include "EXTERN.h"
864dbfa3 15#define PERL_IN_PERL_C
378cc40b 16#include "perl.h"
e3321bb0 17#include "patchlevel.h" /* for local_patches */
378cc40b 18
df5cef82 19/* XXX If this causes problems, set i_unistd=undef in the hint file. */
a0d0e21e
LW		 20#ifdef I_UNISTD
21#include <unistd.h>
22#endif
a0d0e21e 23
54310121 24#if !defined(STANDARD_C) && !defined(HAS_GETENV_PROTOTYPE)
20ce7b12 25char *getenv (char *); /* Usually in <stdlib.h> */
54310121 26#endif
27
0cb96387
GS		 28static I32 read_e_script(pTHXo_ int idx, SV *buf_sv, int maxlen);
29
51fa4eea
JH		 30#ifdef I_FCNTL
31#include <fcntl.h>
32#endif
33#ifdef I_SYS_FILE
34#include <sys/file.h>
35#endif
36
a687059c
LW		 37#ifdef IAMSUID
38#ifndef DOSUID
39#define DOSUID
40#endif
41#endif
378cc40b 42
a687059c
LW		 43#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
44#ifdef DOSUID
45#undef DOSUID
46#endif
47#endif
8d063cd8 48
873ef191 49#ifdef PERL_OBJECT
32e30700
GS		 50CPerlObj*
51perl_alloc(struct IPerlMem* ipM, struct IPerlEnv* ipE,
52 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
53 struct IPerlDir* ipD, struct IPerlSock* ipS,
54 struct IPerlProc* ipP)
01f988be
GS		 55{
56 CPerlObj* pPerl = new(ipM) CPerlObj(ipM, ipE, ipStd, ipLIO, ipD, ipS, ipP);
32e30700 57 if (pPerl != NULL)
01f988be 58 pPerl->Init();
79072805 59
01f988be
GS		 60 return pPerl;
61}
62#else
32e30700
GS		 63
64#ifdef PERL_IMPLICIT_SYS
65PerlInterpreter *
66perl_alloc_using(struct IPerlMem* ipM, struct IPerlEnv* ipE,
67 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
68 struct IPerlDir* ipD, struct IPerlSock* ipS,
69 struct IPerlProc* ipP)
70{
71 PerlInterpreter *my_perl;
72
73 /* New() needs interpreter, so call malloc() instead */
74 my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
75 PERL_SET_INTERP(my_perl);
76 Zero(my_perl, 1, PerlInterpreter);
77 PL_Mem = ipM;
78 PL_Env = ipE;
79 PL_StdIO = ipStd;
80 PL_LIO = ipLIO;
81 PL_Dir = ipD;
82 PL_Sock = ipS;
83 PL_Proc = ipP;
84 return my_perl;
85}
86#else
93a17b20 87PerlInterpreter *
cea2e8a9 88perl_alloc(void)
79072805 89{
cea2e8a9 90 PerlInterpreter *my_perl;
79072805 91
54aff467 92 /* New() needs interpreter, so call malloc() instead */
e8ee3774 93 my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
c5be433b 94 PERL_SET_INTERP(my_perl);
cea2e8a9 95 return my_perl;
79072805 96}
32e30700 97#endif /* PERL_IMPLICIT_SYS */
01f988be 98#endif /* PERL_OBJECT */
79072805
LW		 99
100void
0cb96387 101perl_construct(pTHXx)
79072805 102{
a863c7d1
MB		 103#ifdef USE_THREADS
104 int i;
105#ifndef FAKE_THREADS
e1f15930 106 struct perl_thread *thr = NULL;
a863c7d1
MB		 107#endif /* FAKE_THREADS */
108#endif /* USE_THREADS */
11343788 109
8990e307 110#ifdef MULTIPLICITY
54aff467
GS		 111 init_interp();
112 PL_perl_destruct_level = 1;
113#else
114 if (PL_perl_destruct_level > 0)
115 init_interp();
116#endif
117
33f46ff6 118 /* Init the real globals (and main thread)? */
3280af22 119 if (!PL_linestr) {
11343788 120#ifdef USE_THREADS
8023c3ce 121
33f46ff6 122 INIT_THREADS;
d55594ae
GS		 123#ifdef ALLOC_THREAD_KEY
124 ALLOC_THREAD_KEY;
125#else
533c011a 126 if (pthread_key_create(&PL_thr_key, 0))
cea2e8a9 127 Perl_croak(aTHX_ "panic: pthread_key_create");
d55594ae 128#endif
533c011a 129 MUTEX_INIT(&PL_sv_mutex);
a863c7d1
MB		 130 /*
131 * Safe to use basic SV functions from now on (though
132 * not things like mortals or tainting yet).
133 */
533c011a
NIS		 134 MUTEX_INIT(&PL_eval_mutex);
135 COND_INIT(&PL_eval_cond);
136 MUTEX_INIT(&PL_threads_mutex);
137 COND_INIT(&PL_nthreads_cond);
dce16143 138#ifdef EMULATE_ATOMIC_REFCOUNTS
533c011a 139 MUTEX_INIT(&PL_svref_mutex);
dce16143 140#endif /* EMULATE_ATOMIC_REFCOUNTS */
a863c7d1 141
5ff3f7a4
GS		 142 MUTEX_INIT(&PL_cred_mutex);
143
199100c8 144 thr = init_main_thread();
11343788
MB		 145#endif /* USE_THREADS */
146
0b94c7bb 147 PL_protect = MEMBER_TO_FPTR(Perl_default_protect); /* for exceptions */
312caa8e 148
2aea9f8a
GS		 149 PL_curcop = &PL_compiling; /* needed by ckWARN, right away */
150
3280af22
NIS		 151 PL_linestr = NEWSV(65,79);
152 sv_upgrade(PL_linestr,SVt_PVIV);
79072805 153
3280af22 154 if (!SvREADONLY(&PL_sv_undef)) {
d689ffdd
JP		 155 /* set read-only and try to insure than we wont see REFCNT==0
156 very often */
157
3280af22
NIS		 158 SvREADONLY_on(&PL_sv_undef);
159 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
79072805 160
3280af22
NIS		 161 sv_setpv(&PL_sv_no,PL_No);
162 SvNV(&PL_sv_no);
163 SvREADONLY_on(&PL_sv_no);
164 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
79072805 165
3280af22
NIS		 166 sv_setpv(&PL_sv_yes,PL_Yes);
167 SvNV(&PL_sv_yes);
168 SvREADONLY_on(&PL_sv_yes);
169 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
6e72f9df 170 }
79072805 171
76e3520e
GS		 172#ifdef PERL_OBJECT
173 /* TODO: */
6b88bc9c 174 /* PL_sighandlerp = sighandler; */
76e3520e 175#else
cea2e8a9 176 PL_sighandlerp = Perl_sighandler;
76e3520e 177#endif
3280af22 178 PL_pidstatus = newHV();
44a8e56a 179
79072805
LW		 180#ifdef MSDOS
181 /*
182 * There is no way we can refer to them from Perl so close them to save
183 * space. The other alternative would be to provide STDAUX and STDPRN
184 * filehandles.
185 */
186 (void)fclose(stdaux);
187 (void)fclose(stdprn);
188#endif
189 }
190
79cb57f6 191 PL_nrs = newSVpvn("\n", 1);
3280af22 192 PL_rs = SvREFCNT_inc(PL_nrs);
dc92893f 193
cea2e8a9 194 init_stacks();
79072805 195
748a9306 196 init_ids();
3280af22 197 PL_lex_state = LEX_NOTPARSING;
a5f75d66 198
312caa8e 199 JMPENV_BOOTSTRAP;
f86702cc 200 STATUS_ALL_SUCCESS;
201
0672f40e 202 init_i18nl10n(1);
36477c24 203 SET_NUMERIC_STANDARD();
0b5b802d 204
cceca5ed
GS		 205#if defined(PERL_SUBVERSION) && PERL_SUBVERSION > 0
206 sprintf(PL_patchlevel, "%7.5f", (double) PERL_REVISION
207 + ((double) PERL_VERSION / (double) 1000)
208 + ((double) PERL_SUBVERSION / (double) 100000));
a5f75d66 209#else
cceca5ed
GS		 210 sprintf(PL_patchlevel, "%5.3f", (double) PERL_REVISION +
211 ((double) PERL_VERSION / (double) 1000));
a5f75d66 212#endif
79072805 213
ab821d7f 214#if defined(LOCAL_PATCH_COUNT)
3280af22 215 PL_localpatches = local_patches; /* For possible -v */
ab821d7f 216#endif
217
4b556e6c 218 PerlIO_init(); /* Hook to IO system */
760ac839 219
3280af22
NIS		 220 PL_fdpid = newAV(); /* for remembering popen pids by fd */
221 PL_modglobal = newHV(); /* pointers to per-interpreter module globals */
8990e307 222
8990e307 223 ENTER;
79072805
LW		 224}
225
226void
0cb96387 227perl_destruct(pTHXx)
79072805 228{
11343788 229 dTHR;
748a9306 230 int destruct_level; /* 0=none, 1=full, 2=full with checks */
8990e307 231 I32 last_sv_count;
a0d0e21e 232 HV *hv;
1f2bfc8a 233#ifdef USE_THREADS
33f46ff6 234 Thread t;
cea2e8a9 235 dTHX;
1f2bfc8a 236#endif /* USE_THREADS */
8990e307 237
11343788 238#ifdef USE_THREADS
0f15f207 239#ifndef FAKE_THREADS
8023c3ce
MB		 240 /* Pass 1 on any remaining threads: detach joinables, join zombies */
241 retry_cleanup:
533c011a 242 MUTEX_LOCK(&PL_threads_mutex);
bf49b057 243 DEBUG_S(PerlIO_printf(Perl_debug_log,
c7848ba1 244 "perl_destruct: waiting for %d threads...\n",
533c011a 245 PL_nthreads - 1));
33f46ff6 246 for (t = thr->next; t != thr; t = t->next) {
605e5515
MB		 247 MUTEX_LOCK(&t->mutex);
248 switch (ThrSTATE(t)) {
249 AV *av;
c7848ba1 250 case THRf_ZOMBIE:
bf49b057 251 DEBUG_S(PerlIO_printf(Perl_debug_log,
c7848ba1 252 "perl_destruct: joining zombie %p\n", t));
605e5515
MB		 253 ThrSETSTATE(t, THRf_DEAD);
254 MUTEX_UNLOCK(&t->mutex);
533c011a 255 PL_nthreads--;
8023c3ce
MB		 256 /*
257 * The SvREFCNT_dec below may take a long time (e.g. av
258 * may contain an object scalar whose destructor gets
259 * called) so we have to unlock threads_mutex and start
260 * all over again.
261 */
533c011a 262 MUTEX_UNLOCK(&PL_threads_mutex);
ea0efc06 263 JOIN(t, &av);
605e5515 264 SvREFCNT_dec((SV*)av);
bf49b057 265 DEBUG_S(PerlIO_printf(Perl_debug_log,
c7848ba1 266 "perl_destruct: joined zombie %p OK\n", t));
8023c3ce 267 goto retry_cleanup;
c7848ba1 268 case THRf_R_JOINABLE:
bf49b057 269 DEBUG_S(PerlIO_printf(Perl_debug_log,
c7848ba1
MB		 270 "perl_destruct: detaching thread %p\n", t));
271 ThrSETSTATE(t, THRf_R_DETACHED);
272 /*
273 * We unlock threads_mutex and t->mutex in the opposite order
274 * from which we locked them just so that DETACH won't
275 * deadlock if it panics. It's only a breach of good style
276 * not a bug since they are unlocks not locks.
277 */
533c011a 278 MUTEX_UNLOCK(&PL_threads_mutex);
c7848ba1
MB		 279 DETACH(t);
280 MUTEX_UNLOCK(&t->mutex);
8023c3ce 281 goto retry_cleanup;
c7848ba1 282 default:
bf49b057 283 DEBUG_S(PerlIO_printf(Perl_debug_log,
c7848ba1
MB		 284 "perl_destruct: ignoring %p (state %u)\n",
285 t, ThrSTATE(t)));
286 MUTEX_UNLOCK(&t->mutex);
c7848ba1 287 /* fall through and out */
33f46ff6
MB		 288 }
289 }
8023c3ce
MB		 290 /* We leave the above "Pass 1" loop with threads_mutex still locked */
291
292 /* Pass 2 on remaining threads: wait for the thread count to drop to one */
533c011a 293 while (PL_nthreads > 1)
11343788 294 {
bf49b057 295 DEBUG_S(PerlIO_printf(Perl_debug_log,
c7848ba1 296 "perl_destruct: final wait for %d threads\n",
533c011a
NIS		 297 PL_nthreads - 1));
298 COND_WAIT(&PL_nthreads_cond, &PL_threads_mutex);
11343788
MB		 299 }
300 /* At this point, we're the last thread */
533c011a 301 MUTEX_UNLOCK(&PL_threads_mutex);
bf49b057 302 DEBUG_S(PerlIO_printf(Perl_debug_log, "perl_destruct: armageddon has arrived\n"));
533c011a
NIS		 303 MUTEX_DESTROY(&PL_threads_mutex);
304 COND_DESTROY(&PL_nthreads_cond);
0f15f207 305#endif /* !defined(FAKE_THREADS) */
11343788
MB		 306#endif /* USE_THREADS */
307
3280af22 308 destruct_level = PL_perl_destruct_level;
4633a7c4
LW		 309#ifdef DEBUGGING
310 {
311 char *s;
76e3520e 312 if (s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL")) {
5f05dabc 313 int i = atoi(s);
314 if (destruct_level < i)
315 destruct_level = i;
316 }
4633a7c4
LW		 317 }
318#endif
319
8990e307 320 LEAVE;
a0d0e21e
LW		 321 FREETMPS;
322
ff0cee69 323 /* We must account for everything. */
324
325 /* Destroy the main CV and syntax tree */
3280af22
NIS		 326 if (PL_main_root) {
327 PL_curpad = AvARRAY(PL_comppad);
328 op_free(PL_main_root);
329 PL_main_root = Nullop;
a0d0e21e 330 }
3280af22
NIS		 331 PL_curcop = &PL_compiling;
332 PL_main_start = Nullop;
333 SvREFCNT_dec(PL_main_cv);
334 PL_main_cv = Nullcv;
24d3c518 335 PL_dirty = TRUE;
ff0cee69 336
3280af22 337 if (PL_sv_objcount) {
a0d0e21e
LW		 338 /*
339 * Try to destruct global references. We do this first so that the
340 * destructors and destructees still exist. Some sv's might remain.
341 * Non-referenced objects are on their own.
342 */
a0d0e21e 343 sv_clean_objs();
8990e307
LW		 344 }
345
5cd24f17 346 /* unhook hooks which will soon be, or use, destroyed data */
3280af22
NIS		 347 SvREFCNT_dec(PL_warnhook);
348 PL_warnhook = Nullsv;
349 SvREFCNT_dec(PL_diehook);
350 PL_diehook = Nullsv;
5cd24f17 351
4b556e6c 352 /* call exit list functions */
3280af22 353 while (PL_exitlistlen-- > 0)
0cb96387 354 PL_exitlist[PL_exitlistlen].fn(aTHXo_ PL_exitlist[PL_exitlistlen].ptr);
4b556e6c 355
3280af22 356 Safefree(PL_exitlist);
4b556e6c 357
a0d0e21e 358 if (destruct_level == 0){
8990e307 359
a0d0e21e
LW		 360 DEBUG_P(debprofdump());
361
362 /* The exit() function will do everything that needs doing. */
363 return;
364 }
5dd60ef7 365
5f05dabc 366 /* loosen bonds of global variables */
367
3280af22
NIS		 368 if(PL_rsfp) {
369 (void)PerlIO_close(PL_rsfp);
370 PL_rsfp = Nullfp;
8ebc5c01 371 }
372
373 /* Filters for program text */
3280af22
NIS		 374 SvREFCNT_dec(PL_rsfp_filters);
375 PL_rsfp_filters = Nullav;
8ebc5c01 376
377 /* switches */
3280af22
NIS		 378 PL_preprocess = FALSE;
379 PL_minus_n = FALSE;
380 PL_minus_p = FALSE;
381 PL_minus_l = FALSE;
382 PL_minus_a = FALSE;
383 PL_minus_F = FALSE;
384 PL_doswitches = FALSE;
599cee73 385 PL_dowarn = G_WARN_OFF;
3280af22
NIS		 386 PL_doextract = FALSE;
387 PL_sawampersand = FALSE; /* must save all match strings */
3280af22
NIS		 388 PL_unsafe = FALSE;
389
390 Safefree(PL_inplace);
391 PL_inplace = Nullch;
392
393 if (PL_e_script) {
394 SvREFCNT_dec(PL_e_script);
395 PL_e_script = Nullsv;
8ebc5c01 396 }
397
398 /* magical thingies */
399
3280af22
NIS		 400 Safefree(PL_ofs); /* $, */
401 PL_ofs = Nullch;
5f05dabc 402
3280af22
NIS		 403 Safefree(PL_ors); /* $\ */
404 PL_ors = Nullch;
8ebc5c01 405
3280af22
NIS		 406 SvREFCNT_dec(PL_rs); /* $/ */
407 PL_rs = Nullsv;
dc92893f 408
3280af22
NIS		 409 SvREFCNT_dec(PL_nrs); /* $/ helper */
410 PL_nrs = Nullsv;
5f05dabc 411
3280af22 412 PL_multiline = 0; /* $* */
5f05dabc 413
3280af22
NIS		 414 SvREFCNT_dec(PL_statname);
415 PL_statname = Nullsv;
416 PL_statgv = Nullgv;
5f05dabc 417
8ebc5c01 418 /* defgv, aka *_ should be taken care of elsewhere */
419
8ebc5c01 420 /* clean up after study() */
3280af22
NIS		 421 SvREFCNT_dec(PL_lastscream);
422 PL_lastscream = Nullsv;
423 Safefree(PL_screamfirst);
424 PL_screamfirst = 0;
425 Safefree(PL_screamnext);
426 PL_screamnext = 0;
8ebc5c01 427
7d5ea4e7
GS		 428 /* float buffer */
429 Safefree(PL_efloatbuf);
430 PL_efloatbuf = Nullch;
431 PL_efloatsize = 0;
432
8ebc5c01 433 /* startup and shutdown function lists */
3280af22
NIS		 434 SvREFCNT_dec(PL_beginav);
435 SvREFCNT_dec(PL_endav);
4f25aa18 436 SvREFCNT_dec(PL_stopav);
3280af22
NIS		 437 SvREFCNT_dec(PL_initav);
438 PL_beginav = Nullav;
439 PL_endav = Nullav;
4f25aa18 440 PL_stopav = Nullav;
3280af22 441 PL_initav = Nullav;
5618dfe8 442
8ebc5c01 443 /* shortcuts just get cleared */
3280af22 444 PL_envgv = Nullgv;
3280af22
NIS		 445 PL_incgv = Nullgv;
446 PL_hintgv = Nullgv;
447 PL_errgv = Nullgv;
448 PL_argvgv = Nullgv;
449 PL_argvoutgv = Nullgv;
450 PL_stdingv = Nullgv;
bf49b057 451 PL_stderrgv = Nullgv;
3280af22
NIS		 452 PL_last_in_gv = Nullgv;
453 PL_replgv = Nullgv;
8ebc5c01 454
455 /* reset so print() ends up where we expect */
456 setdefout(Nullgv);
7a1c5554
GS		 457 SvREFCNT_dec(PL_argvout_stack);
458 PL_argvout_stack = Nullav;
8ebc5c01 459
a0d0e21e 460 /* Prepare to destruct main symbol table. */
5f05dabc 461
3280af22
NIS		 462 hv = PL_defstash;
463 PL_defstash = 0;
a0d0e21e
LW		 464 SvREFCNT_dec(hv);
465
5a844595
GS		 466 /* clear queued errors */
467 SvREFCNT_dec(PL_errors);
468 PL_errors = Nullsv;
469
a0d0e21e 470 FREETMPS;
0453d815 471 if (destruct_level >= 2 && ckWARN_d(WARN_INTERNAL)) {
3280af22 472 if (PL_scopestack_ix != 0)
0453d815
PM		 473 Perl_warner(aTHX_ WARN_INTERNAL,
474 "Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
3280af22
NIS		 475 (long)PL_scopestack_ix);
476 if (PL_savestack_ix != 0)
0453d815
PM		 477 Perl_warner(aTHX_ WARN_INTERNAL,
478 "Unbalanced saves: %ld more saves than restores\n",
3280af22
NIS		 479 (long)PL_savestack_ix);
480 if (PL_tmps_floor != -1)
0453d815 481 Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced tmps: %ld more allocs than frees\n",
3280af22 482 (long)PL_tmps_floor + 1);
a0d0e21e 483 if (cxstack_ix != -1)
0453d815 484 Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced context: %ld more PUSHes than POPs\n",
ff0cee69 485 (long)cxstack_ix + 1);
a0d0e21e 486 }
8990e307
LW		 487
488 /* Now absolutely destruct everything, somehow or other, loops or no. */
8990e307 489 last_sv_count = 0;
3280af22
NIS		 490 SvFLAGS(PL_strtab) |= SVTYPEMASK; /* don't clean out strtab now */
491 while (PL_sv_count != 0 && PL_sv_count != last_sv_count) {
492 last_sv_count = PL_sv_count;
8990e307
LW		 493 sv_clean_all();
494 }
3280af22
NIS		 495 SvFLAGS(PL_strtab) &= ~SVTYPEMASK;
496 SvFLAGS(PL_strtab) |= SVt_PVHV;
6e72f9df 497
498 /* Destruct the global string table. */
499 {
500 /* Yell and reset the HeVAL() slots that are still holding refcounts,
501 * so that sv_free() won't fail on them.
502 */
503 I32 riter;
504 I32 max;
505 HE *hent;
506 HE **array;
507
508 riter = 0;
3280af22
NIS		 509 max = HvMAX(PL_strtab);
510 array = HvARRAY(PL_strtab);
6e72f9df 511 hent = array[0];
512 for (;;) {
0453d815
PM		 513 if (hent && ckWARN_d(WARN_INTERNAL)) {
514 Perl_warner(aTHX_ WARN_INTERNAL,
515 "Unbalanced string table refcount: (%d) for \"%s\"",
6e72f9df 516 HeVAL(hent) - Nullsv, HeKEY(hent));
517 HeVAL(hent) = Nullsv;
518 hent = HeNEXT(hent);
519 }
520 if (!hent) {
521 if (++riter > max)
522 break;
523 hent = array[riter];
524 }
525 }
526 }
3280af22 527 SvREFCNT_dec(PL_strtab);
6e72f9df 528
0453d815
PM		 529 if (PL_sv_count != 0 && ckWARN_d(WARN_INTERNAL))
530 Perl_warner(aTHX_ WARN_INTERNAL,"Scalars leaked: %ld\n", (long)PL_sv_count);
6e72f9df 531
4633a7c4 532 sv_free_arenas();
44a8e56a 533
534 /* No SVs have survived, need to clean out */
3280af22
NIS		 535 PL_linestr = NULL;
536 PL_pidstatus = Nullhv;
537 Safefree(PL_origfilename);
538 Safefree(PL_archpat_auto);
539 Safefree(PL_reg_start_tmp);
5c5e4c24
IZ		 540 if (PL_reg_curpm)
541 Safefree(PL_reg_curpm);
82ba1be6 542 Safefree(PL_reg_poscache);
3280af22
NIS		 543 Safefree(HeKEY_hek(&PL_hv_fetch_ent_mh));
544 Safefree(PL_op_mask);
6e72f9df 545 nuke_stacks();
3280af22 546 PL_hints = 0; /* Reset hints. Should hints be per-interpreter ? */
a0d0e21e
LW		 547
548 DEBUG_P(debprofdump());
11343788 549#ifdef USE_THREADS
5f08fbcd 550 MUTEX_DESTROY(&PL_strtab_mutex);
533c011a
NIS		 551 MUTEX_DESTROY(&PL_sv_mutex);
552 MUTEX_DESTROY(&PL_eval_mutex);
5ff3f7a4 553 MUTEX_DESTROY(&PL_cred_mutex);
533c011a 554 COND_DESTROY(&PL_eval_cond);
11d617a5
GS		 555#ifdef EMULATE_ATOMIC_REFCOUNTS
556 MUTEX_DESTROY(&PL_svref_mutex);
557#endif /* EMULATE_ATOMIC_REFCOUNTS */
fc36a67e 558
8023c3ce 559 /* As the penultimate thing, free the non-arena SV for thrsv */
533c011a
NIS		 560 Safefree(SvPVX(PL_thrsv));
561 Safefree(SvANY(PL_thrsv));
562 Safefree(PL_thrsv);
563 PL_thrsv = Nullsv;
8023c3ce
MB		 564#endif /* USE_THREADS */
565
fc36a67e 566 /* As the absolutely last thing, free the non-arena SV for mess() */
567
3280af22 568 if (PL_mess_sv) {
9c63abab
GS		 569 /* it could have accumulated taint magic */
570 if (SvTYPE(PL_mess_sv) >= SVt_PVMG) {
571 MAGIC* mg;
572 MAGIC* moremagic;
573 for (mg = SvMAGIC(PL_mess_sv); mg; mg = moremagic) {
574 moremagic = mg->mg_moremagic;
575 if (mg->mg_ptr && mg->mg_type != 'g' && mg->mg_len >= 0)
576 Safefree(mg->mg_ptr);
577 Safefree(mg);
578 }
579 }
fc36a67e 580 /* we know that type >= SVt_PV */
3280af22
NIS		 581 SvOOK_off(PL_mess_sv);
582 Safefree(SvPVX(PL_mess_sv));
583 Safefree(SvANY(PL_mess_sv));
584 Safefree(PL_mess_sv);
585 PL_mess_sv = Nullsv;
fc36a67e 586 }
79072805
LW		 587}
588
589void
0cb96387 590perl_free(pTHXx)
79072805 591{
c5be433b 592#if defined(PERL_OBJECT)
7f0d82f7 593 PerlMem_free(this);
76e3520e 594#else
7f0d82f7 595 PerlMem_free(aTHXx);
76e3520e 596#endif
79072805
LW		 597}
598
4b556e6c 599void
864dbfa3 600Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr)
4b556e6c 601{
3280af22
NIS		 602 Renew(PL_exitlist, PL_exitlistlen+1, PerlExitListEntry);
603 PL_exitlist[PL_exitlistlen].fn = fn;
604 PL_exitlist[PL_exitlistlen].ptr = ptr;
605 ++PL_exitlistlen;
4b556e6c
JD		 606}
607
79072805 608int
0cb96387 609perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env)
8d063cd8 610{
11343788 611 dTHR;
6224f72b 612 I32 oldscope;
6224f72b 613 int ret;
db36c5a1 614 dJMPENV;
cea2e8a9
GS		 615#ifdef USE_THREADS
616 dTHX;
617#endif
8d063cd8 618
a687059c
LW		 619#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
620#ifdef IAMSUID
621#undef IAMSUID
cea2e8a9 622 Perl_croak(aTHX_ "suidperl is no longer needed since the kernel can now execute\n\
a687059c
LW		 623setuid perl scripts securely.\n");
624#endif
625#endif
626
8f1f23e8 627#if defined(__DYNAMIC__) && (defined(NeXT) || defined(__NeXT__))
6e72f9df 628 _dyld_lookup_and_bind
629 ("__environ", (unsigned long *) &environ_pointer, NULL);
630#endif /* environ */
631
3280af22
NIS		 632 PL_origargv = argv;
633 PL_origargc = argc;
a0d0e21e 634#ifndef VMS /* VMS doesn't have environ array */
3280af22 635 PL_origenviron = environ;
a0d0e21e
LW		 636#endif
637
3280af22 638 if (PL_do_undump) {
a0d0e21e
LW		 639
640 /* Come here if running an undumped a.out. */
641
3280af22
NIS		 642 PL_origfilename = savepv(argv[0]);
643 PL_do_undump = FALSE;
a0d0e21e 644 cxstack_ix = -1; /* start label stack again */
748a9306 645 init_ids();
a0d0e21e
LW		 646 init_postdump_symbols(argc,argv,env);
647 return 0;
648 }
649
3280af22
NIS		 650 if (PL_main_root) {
651 PL_curpad = AvARRAY(PL_comppad);
652 op_free(PL_main_root);
653 PL_main_root = Nullop;
ff0cee69 654 }
3280af22
NIS		 655 PL_main_start = Nullop;
656 SvREFCNT_dec(PL_main_cv);
657 PL_main_cv = Nullcv;
79072805 658
3280af22
NIS		 659 time(&PL_basetime);
660 oldscope = PL_scopestack_ix;
599cee73 661 PL_dowarn = G_WARN_OFF;
f86702cc 662
db36c5a1
GS		 663 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_parse_body),
664 env, xsinit);
6224f72b 665 switch (ret) {
312caa8e 666 case 0:
4f25aa18
GS		 667 if (PL_stopav)
668 call_list(oldscope, PL_stopav);
312caa8e 669 return 0;
6224f72b
GS		 670 case 1:
671 STATUS_ALL_FAILURE;
672 /* FALL THROUGH */
673 case 2:
674 /* my_exit() was called */
3280af22 675 while (PL_scopestack_ix > oldscope)
6224f72b
GS		 676 LEAVE;
677 FREETMPS;
3280af22 678 PL_curstash = PL_defstash;
4f25aa18
GS		 679 if (PL_stopav)
680 call_list(oldscope, PL_stopav);
6224f72b
GS		 681 return STATUS_NATIVE_EXPORT;
682 case 3:
bf49b057 683 PerlIO_printf(Perl_error_log, "panic: top_env\n");
6224f72b
GS		 684 return 1;
685 }
a6c40364 686 return 0;
312caa8e
CS		 687}
688
689STATIC void *
cea2e8a9 690S_parse_body(pTHX_ va_list args)
312caa8e
CS		 691{
692 dTHR;
693 int argc = PL_origargc;
694 char **argv = PL_origargv;
695 char **env = va_arg(args, char**);
696 char *scriptname = NULL;
697 int fdscript = -1;
698 VOL bool dosearch = FALSE;
699 char *validarg = "";
700 AV* comppadlist;
701 register SV *sv;
702 register char *s;
f4c556ac 703 char *cddir = Nullch;
312caa8e 704
864dbfa3 705 XSINIT_t xsinit = va_arg(args, XSINIT_t);
79072805 706
3280af22 707 sv_setpvn(PL_linestr,"",0);
79cb57f6 708 sv = newSVpvn("",0); /* first used for -I flags */
6224f72b
GS		 709 SAVEFREESV(sv);
710 init_main_stash();
54310121 711
6224f72b
GS		 712 for (argc--,argv++; argc > 0; argc--,argv++) {
713 if (argv[0][0] != '-' || !argv[0][1])
714 break;
715#ifdef DOSUID
716 if (*validarg)
717 validarg = " PHOOEY ";
718 else
719 validarg = argv[0];
13281fa4 720#endif
6224f72b
GS		 721 s = argv[0]+1;
722 reswitch:
723 switch (*s) {
1d5472a9
GS		 724#ifndef PERL_STRICT_CR
725 case '\r':
726#endif
6224f72b
GS		 727 case ' ':
728 case '0':
729 case 'F':
730 case 'a':
731 case 'c':
732 case 'd':
733 case 'D':
734 case 'h':
735 case 'i':
736 case 'l':
737 case 'M':
738 case 'm':
739 case 'n':
740 case 'p':
741 case 's':
742 case 'u':
743 case 'U':
744 case 'v':
599cee73
PM		 745 case 'W':
746 case 'X':
6224f72b
GS		 747 case 'w':
748 if (s = moreswitches(s))
749 goto reswitch;
750 break;
33b78306 751
6224f72b 752 case 'T':
3280af22 753 PL_tainting = TRUE;
6224f72b
GS		 754 s++;
755 goto reswitch;
f86702cc 756
6224f72b 757 case 'e':
3280af22 758 if (PL_euid != PL_uid || PL_egid != PL_gid)
cea2e8a9 759 Perl_croak(aTHX_ "No -e allowed in setuid scripts");
3280af22 760 if (!PL_e_script) {
79cb57f6 761 PL_e_script = newSVpvn("",0);
0cb96387 762 filter_add(read_e_script, NULL);
6224f72b
GS		 763 }
764 if (*++s)
3280af22 765 sv_catpv(PL_e_script, s);
6224f72b 766 else if (argv[1]) {
3280af22 767 sv_catpv(PL_e_script, argv[1]);
6224f72b
GS		 768 argc--,argv++;
769 }
770 else
cea2e8a9 771 Perl_croak(aTHX_ "No code specified for -e");
3280af22 772 sv_catpv(PL_e_script, "\n");
6224f72b 773 break;
afe37c7d 774
6224f72b
GS		 775 case 'I': /* -I handled both here and in moreswitches() */
776 forbid_setid("-I");
777 if (!*++s && (s=argv[1]) != Nullch) {
778 argc--,argv++;
779 }
780 while (s && isSPACE(*s))
781 ++s;
782 if (s && *s) {
783 char *e, *p;
784 for (e = s; *e && !isSPACE(*e); e++) ;
785 p = savepvn(s, e-s);
786 incpush(p, TRUE);
787 sv_catpv(sv,"-I");
788 sv_catpv(sv,p);
789 sv_catpv(sv," ");
790 Safefree(p);
791 } /* XXX else croak? */
792 break;
793 case 'P':
794 forbid_setid("-P");
3280af22 795 PL_preprocess = TRUE;
6224f72b
GS		 796 s++;
797 goto reswitch;
798 case 'S':
799 forbid_setid("-S");
800 dosearch = TRUE;
801 s++;
802 goto reswitch;
803 case 'V':
3280af22
NIS		 804 if (!PL_preambleav)
805 PL_preambleav = newAV();
806 av_push(PL_preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
6224f72b 807 if (*++s != ':') {
3280af22 808 PL_Sv = newSVpv("print myconfig();",0);
6224f72b 809#ifdef VMS
6b88bc9c 810 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
6224f72b 811#else
3280af22 812 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
6224f72b 813#endif
3280af22 814 sv_catpv(PL_Sv,"\" Compile-time options:");
6224f72b 815# ifdef DEBUGGING
3280af22 816 sv_catpv(PL_Sv," DEBUGGING");
6224f72b 817# endif
6224f72b 818# ifdef MULTIPLICITY
8f872242 819 sv_catpv(PL_Sv," MULTIPLICITY");
6224f72b 820# endif
b363f7ed
GS		 821# ifdef USE_THREADS
822 sv_catpv(PL_Sv," USE_THREADS");
823# endif
824# ifdef PERL_OBJECT
825 sv_catpv(PL_Sv," PERL_OBJECT");
826# endif
827# ifdef PERL_IMPLICIT_CONTEXT
828 sv_catpv(PL_Sv," PERL_IMPLICIT_CONTEXT");
829# endif
830# ifdef PERL_IMPLICIT_SYS
831 sv_catpv(PL_Sv," PERL_IMPLICIT_SYS");
832# endif
3280af22 833 sv_catpv(PL_Sv,"\\n\",");
b363f7ed 834
6224f72b
GS		 835#if defined(LOCAL_PATCH_COUNT)
836 if (LOCAL_PATCH_COUNT > 0) {
837 int i;
3280af22 838 sv_catpv(PL_Sv,"\" Locally applied patches:\\n\",");
6224f72b 839 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
3280af22 840 if (PL_localpatches[i])
cea2e8a9 841 Perl_sv_catpvf(aTHX_ PL_Sv,"q\" \t%s\n\",",PL_localpatches[i]);
6224f72b
GS		 842 }
843 }
844#endif
cea2e8a9 845 Perl_sv_catpvf(aTHX_ PL_Sv,"\" Built under %s\\n\"",OSNAME);
6224f72b
GS		 846#ifdef __DATE__
847# ifdef __TIME__
cea2e8a9 848 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
6224f72b 849# else
cea2e8a9 850 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled on %s\\n\"",__DATE__);
6224f72b
GS		 851# endif
852#endif
3280af22 853 sv_catpv(PL_Sv, "; \
6224f72b
GS		 854$\"=\"\\n \"; \
855@env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; \
856print \" \\%ENV:\\n @env\\n\" if @env; \
857print \" \\@INC:\\n @INC\\n\";");
858 }
859 else {
3280af22
NIS		 860 PL_Sv = newSVpv("config_vars(qw(",0);
861 sv_catpv(PL_Sv, ++s);
862 sv_catpv(PL_Sv, "))");
6224f72b
GS		 863 s += strlen(s);
864 }
3280af22 865 av_push(PL_preambleav, PL_Sv);
6224f72b
GS		 866 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
867 goto reswitch;
868 case 'x':
3280af22 869 PL_doextract = TRUE;
6224f72b
GS		 870 s++;
871 if (*s)
f4c556ac 872 cddir = s;
6224f72b
GS		 873 break;
874 case 0:
875 break;
876 case '-':
877 if (!*++s || isSPACE(*s)) {
878 argc--,argv++;
879 goto switch_end;
880 }
881 /* catch use of gnu style long options */
882 if (strEQ(s, "version")) {
883 s = "v";
884 goto reswitch;
885 }
886 if (strEQ(s, "help")) {
887 s = "h";
888 goto reswitch;
889 }
890 s--;
891 /* FALL THROUGH */
892 default:
cea2e8a9 893 Perl_croak(aTHX_ "Unrecognized switch: -%s (-h will show valid options)",s);
8d063cd8
LW		 894 }
895 }
6224f72b 896 switch_end:
54310121 897
f675dbe5
CB		 898 if (
899#ifndef SECURE_INTERNAL_GETENV
900 !PL_tainting &&
901#endif
902 (s = PerlEnv_getenv("PERL5OPT"))) {
74288ac8
GS		 903 while (isSPACE(*s))
904 s++;
905 if (*s == '-' && *(s+1) == 'T')
906 PL_tainting = TRUE;
907 else {
908 while (s && *s) {
909 while (isSPACE(*s))
910 s++;
911 if (*s == '-') {
912 s++;
913 if (isSPACE(*s))
914 continue;
915 }
916 if (!*s)
917 break;
918 if (!strchr("DIMUdmw", *s))
cea2e8a9 919 Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s);
74288ac8 920 s = moreswitches(s);
6224f72b 921 }
6224f72b
GS		 922 }
923 }
a0d0e21e 924
6224f72b
GS		 925 if (!scriptname)
926 scriptname = argv[0];
3280af22 927 if (PL_e_script) {
6224f72b
GS		 928 argc++,argv--;
929 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
930 }
931 else if (scriptname == Nullch) {
932#ifdef MSDOS
933 if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
934 moreswitches("h");
935#endif
936 scriptname = "-";
937 }
938
939 init_perllib();
940
941 open_script(scriptname,dosearch,sv,&fdscript);
942
943 validate_suid(validarg, scriptname,fdscript);
944
0b5b802d
GS		 945#if defined(SIGCHLD) || defined(SIGCLD)
946 {
947#ifndef SIGCHLD
948# define SIGCHLD SIGCLD
949#endif
950 Sighandler_t sigstate = rsignal_state(SIGCHLD);
951 if (sigstate == SIG_IGN) {
952 if (ckWARN(WARN_SIGNAL))
953 Perl_warner(aTHX_ WARN_SIGNAL,
954 "Can't ignore signal CHLD, forcing to default");
955 (void)rsignal(SIGCHLD, (Sighandler_t)SIG_DFL);
956 }
957 }
958#endif
959
f4c556ac 960 if (PL_doextract) {
6224f72b 961 find_beginning();
f4c556ac
GS		 962 if (cddir && PerlDir_chdir(cddir) < 0)
963 Perl_croak(aTHX_ "Can't chdir to %s",cddir);
964
965 }
6224f72b 966
3280af22
NIS		 967 PL_main_cv = PL_compcv = (CV*)NEWSV(1104,0);
968 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
969 CvUNIQUE_on(PL_compcv);
970
971 PL_comppad = newAV();
972 av_push(PL_comppad, Nullsv);
973 PL_curpad = AvARRAY(PL_comppad);
974 PL_comppad_name = newAV();
975 PL_comppad_name_fill = 0;
976 PL_min_intro_pending = 0;
977 PL_padix = 0;
6224f72b 978#ifdef USE_THREADS
79cb57f6 979 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
533c011a
NIS		 980 PL_curpad[0] = (SV*)newAV();
981 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
982 CvOWNER(PL_compcv) = 0;
983 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
984 MUTEX_INIT(CvMUTEXP(PL_compcv));
6224f72b
GS		 985#endif /* USE_THREADS */
986
987 comppadlist = newAV();
988 AvREAL_off(comppadlist);
3280af22
NIS		 989 av_store(comppadlist, 0, (SV*)PL_comppad_name);
990 av_store(comppadlist, 1, (SV*)PL_comppad);
991 CvPADLIST(PL_compcv) = comppadlist;
6224f72b
GS		 992
993 boot_core_UNIVERSAL();
09bef843 994 boot_core_xsutils();
6224f72b
GS		 995
996 if (xsinit)
0cb96387 997 (*xsinit)(aTHXo); /* in case linked C routines want magical variables */
6224f72b 998#if defined(VMS) || defined(WIN32) || defined(DJGPP)
c5be433b 999 init_os_extras();
6224f72b
GS		 1000#endif
1001
29209bc5
JH		 1002#ifdef USE_SOCKS
1003 SOCKSinit(argv[0]);
1004#endif
1005
6224f72b
GS		 1006 init_predump_symbols();
1007 /* init_postdump_symbols not currently designed to be called */
1008 /* more than once (ENV isn't cleared first, for example) */
1009 /* But running with -u leaves %ENV & @ARGV undefined! XXX */
3280af22 1010 if (!PL_do_undump)
6224f72b
GS		 1011 init_postdump_symbols(argc,argv,env);
1012
1013 init_lexer();
1014
1015 /* now parse the script */
1016
1017 SETERRNO(0,SS$_NORMAL);
3280af22
NIS		 1018 PL_error_count = 0;
1019 if (yyparse() || PL_error_count) {
1020 if (PL_minus_c)
cea2e8a9 1021 Perl_croak(aTHX_ "%s had compilation errors.\n", PL_origfilename);
6224f72b 1022 else {
cea2e8a9 1023 Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
097ee67d 1024 PL_origfilename);
6224f72b
GS		 1025 }
1026 }
3280af22
NIS		 1027 PL_curcop->cop_line = 0;
1028 PL_curstash = PL_defstash;
1029 PL_preprocess = FALSE;
1030 if (PL_e_script) {
1031 SvREFCNT_dec(PL_e_script);
1032 PL_e_script = Nullsv;
6224f72b
GS		 1033 }
1034
1035 /* now that script is parsed, we can modify record separator */
3280af22
NIS		 1036 SvREFCNT_dec(PL_rs);
1037 PL_rs = SvREFCNT_inc(PL_nrs);
864dbfa3 1038 sv_setsv(get_sv("/", TRUE), PL_rs);
3280af22 1039 if (PL_do_undump)
6224f72b
GS		 1040 my_unexec();
1041
0453d815 1042 if (isWARN_ONCE)
3280af22 1043 gv_check(PL_defstash);
6224f72b
GS		 1044
1045 LEAVE;
1046 FREETMPS;
1047
1048#ifdef MYMALLOC
1049 if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
1050 dump_mstats("after compilation:");
1051#endif
1052
1053 ENTER;
3280af22 1054 PL_restartop = 0;
312caa8e 1055 return NULL;
6224f72b
GS		 1056}
1057
1058int
0cb96387 1059perl_run(pTHXx)
6224f72b 1060{
de616352 1061 dTHR;
6224f72b 1062 I32 oldscope;
6224f72b 1063 int ret;
db36c5a1 1064 dJMPENV;
cea2e8a9
GS		 1065#ifdef USE_THREADS
1066 dTHX;
1067#endif
6224f72b 1068
3280af22 1069 oldscope = PL_scopestack_ix;
6224f72b 1070
312caa8e 1071 redo_body:
db36c5a1 1072 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_run_body), oldscope);
6224f72b
GS		 1073 switch (ret) {
1074 case 1:
1075 cxstack_ix = -1; /* start context stack again */
312caa8e
CS		 1076 goto redo_body;
1077 case 0: /* normal completion */
1078 case 2: /* my_exit() */
3280af22 1079 while (PL_scopestack_ix > oldscope)
6224f72b
GS		 1080 LEAVE;
1081 FREETMPS;
3280af22 1082 PL_curstash = PL_defstash;
865be832 1083 if (PL_endav && !PL_minus_c)
3280af22 1084 call_list(oldscope, PL_endav);
6224f72b
GS		 1085#ifdef MYMALLOC
1086 if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
1087 dump_mstats("after execution: ");
1088#endif
6224f72b
GS		 1089 return STATUS_NATIVE_EXPORT;
1090 case 3:
312caa8e
CS		 1091 if (PL_restartop) {
1092 POPSTACK_TO(PL_mainstack);
1093 goto redo_body;
6224f72b 1094 }
bf49b057 1095 PerlIO_printf(Perl_error_log, "panic: restartop\n");
312caa8e
CS		 1096 FREETMPS;
1097 return 1;
6224f72b
GS		 1098 }
1099
312caa8e
CS		 1100 /* NOTREACHED */
1101 return 0;
1102}
1103
1104STATIC void *
cea2e8a9 1105S_run_body(pTHX_ va_list args)
312caa8e
CS		 1106{
1107 dTHR;
1108 I32 oldscope = va_arg(args, I32);
1109
6224f72b 1110 DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
3280af22 1111 PL_sawampersand ? "Enabling" : "Omitting"));
6224f72b 1112
3280af22 1113 if (!PL_restartop) {
6224f72b
GS		 1114 DEBUG_x(dump_all());
1115 DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
b900a521
JH		 1116 DEBUG_S(PerlIO_printf(Perl_debug_log, "main thread is 0x%"UVxf"\n",
1117 PTR2UV(thr)));
6224f72b 1118
3280af22 1119 if (PL_minus_c) {
bf49b057 1120 PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename);
6224f72b
GS		 1121 my_exit(0);
1122 }
3280af22 1123 if (PERLDB_SINGLE && PL_DBsingle)
312caa8e 1124 sv_setiv(PL_DBsingle, 1);
3280af22
NIS		 1125 if (PL_initav)
1126 call_list(oldscope, PL_initav);
6224f72b
GS		 1127 }
1128
1129 /* do it */
1130
3280af22 1131 if (PL_restartop) {
533c011a 1132 PL_op = PL_restartop;
3280af22 1133 PL_restartop = 0;
cea2e8a9 1134 CALLRUNOPS(aTHX);
6224f72b 1135 }
3280af22
NIS		 1136 else if (PL_main_start) {
1137 CvDEPTH(PL_main_cv) = 1;
533c011a 1138 PL_op = PL_main_start;
cea2e8a9 1139 CALLRUNOPS(aTHX);
6224f72b
GS		 1140 }
1141
f6b3007c
JH		 1142 my_exit(0);
1143 /* NOTREACHED */
312caa8e 1144 return NULL;
6224f72b
GS		 1145}
1146
1147SV*
864dbfa3 1148Perl_get_sv(pTHX_ const char *name, I32 create)
6224f72b
GS		 1149{
1150 GV *gv;
1151#ifdef USE_THREADS
1152 if (name[1] == '\0' && !isALPHA(name[0])) {
1153 PADOFFSET tmp = find_threadsv(name);
1154 if (tmp != NOT_IN_PAD) {
1155 dTHR;
1156 return THREADSV(tmp);
1157 }
1158 }
1159#endif /* USE_THREADS */
1160 gv = gv_fetchpv(name, create, SVt_PV);
1161 if (gv)
1162 return GvSV(gv);
1163 return Nullsv;
1164}
1165
1166AV*
864dbfa3 1167Perl_get_av(pTHX_ const char *name, I32 create)
6224f72b
GS		 1168{
1169 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
1170 if (create)
1171 return GvAVn(gv);
1172 if (gv)
1173 return GvAV(gv);
1174 return Nullav;
1175}
1176
1177HV*
864dbfa3 1178Perl_get_hv(pTHX_ const char *name, I32 create)
6224f72b 1179{
a0d0e21e
LW		 1180 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
1181 if (create)
1182 return GvHVn(gv);
1183 if (gv)
1184 return GvHV(gv);
1185 return Nullhv;
1186}
1187
1188CV*
864dbfa3 1189Perl_get_cv(pTHX_ const char *name, I32 create)
a0d0e21e
LW		 1190{
1191 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
b099ddc0 1192 /* XXX unsafe for threads if eval_owner isn't held */
f6ec51f7
GS		 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
1195 * declaration! */
8ebc5c01 1196 if (create && !GvCVu(gv))
774d564b 1197 return newSUB(start_subparse(FALSE, 0),
a0d0e21e 1198 newSVOP(OP_CONST, 0, newSVpv(name,0)),
4633a7c4 1199 Nullop,
a0d0e21e
LW		 1200 Nullop);
1201 if (gv)
8ebc5c01 1202 return GvCVu(gv);
a0d0e21e
LW		 1203 return Nullcv;
1204}
1205
79072805
LW		 1206/* Be sure to refetch the stack pointer after calling these routines. */
1207
a0d0e21e 1208I32
864dbfa3 1209Perl_call_argv(pTHX_ const char *sub_name, I32 flags, register char **argv)
8ac85365
NIS		 1210
1211 /* See G_* flags in cop.h */
1212 /* null terminated arg list */
8990e307 1213{
a0d0e21e 1214 dSP;
8990e307 1215
924508f0 1216 PUSHMARK(SP);
a0d0e21e 1217 if (argv) {
8990e307 1218 while (*argv) {
a0d0e21e 1219 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
8990e307
LW		 1220 argv++;
1221 }
a0d0e21e 1222 PUTBACK;
8990e307 1223 }
864dbfa3 1224 return call_pv(sub_name, flags);
8990e307
LW		 1225}
1226
a0d0e21e 1227I32
864dbfa3 1228Perl_call_pv(pTHX_ const char *sub_name, I32 flags)
8ac85365
NIS		 1229 /* name of the subroutine */
1230 /* See G_* flags in cop.h */
a0d0e21e 1231{
864dbfa3 1232 return call_sv((SV*)get_cv(sub_name, TRUE), flags);
a0d0e21e
LW		 1233}
1234
1235I32
864dbfa3 1236Perl_call_method(pTHX_ const char *methname, I32 flags)
8ac85365
NIS		 1237 /* name of the subroutine */
1238 /* See G_* flags in cop.h */
a0d0e21e
LW		 1239{
1240 dSP;
1241 OP myop;
533c011a
NIS		 1242 if (!PL_op)
1243 PL_op = &myop;
a0d0e21e
LW		 1244 XPUSHs(sv_2mortal(newSVpv(methname,0)));
1245 PUTBACK;
cea2e8a9 1246 pp_method();
533c011a
NIS		 1247 if(PL_op == &myop)
1248 PL_op = Nullop;
864dbfa3 1249 return call_sv(*PL_stack_sp--, flags);
a0d0e21e
LW		 1250}
1251
1252/* May be called with any of a CV, a GV, or an SV containing the name. */
1253I32
864dbfa3 1254Perl_call_sv(pTHX_ SV *sv, I32 flags)
8ac85365
NIS		 1255
1256 /* See G_* flags in cop.h */
a0d0e21e 1257{
924508f0 1258 dSP;
a0d0e21e 1259 LOGOP myop; /* fake syntax tree node */
aa689395 1260 I32 oldmark;
a0d0e21e 1261 I32 retval;
a0d0e21e 1262 I32 oldscope;
54310121 1263 bool oldcatch = CATCH_GET;
6224f72b 1264 int ret;
533c011a 1265 OP* oldop = PL_op;
db36c5a1 1266 dJMPENV;
1e422769 1267
a0d0e21e
LW		 1268 if (flags & G_DISCARD) {
1269 ENTER;
1270 SAVETMPS;
1271 }
1272
aa689395 1273 Zero(&myop, 1, LOGOP);
54310121 1274 myop.op_next = Nullop;
f51d4af5 1275 if (!(flags & G_NOARGS))
aa689395 1276 myop.op_flags |= OPf_STACKED;
54310121 1277 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1278 (flags & G_ARRAY) ? OPf_WANT_LIST :
1279 OPf_WANT_SCALAR);
462e5cf6 1280 SAVEOP();
533c011a 1281 PL_op = (OP*)&myop;
aa689395 1282
3280af22
NIS		 1283 EXTEND(PL_stack_sp, 1);
1284 *++PL_stack_sp = sv;
aa689395 1285 oldmark = TOPMARK;
3280af22 1286 oldscope = PL_scopestack_ix;
a0d0e21e 1287
3280af22 1288 if (PERLDB_SUB && PL_curstash != PL_debstash
36477c24 1289 /* Handle first BEGIN of -d. */
3280af22 1290 && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub)))
36477c24 1291 /* Try harder, since this may have been a sighandler, thus
1292 * curstash may be meaningless. */
3280af22 1293 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != PL_debstash)
491527d0 1294 && !(flags & G_NODEBUG))
533c011a 1295 PL_op->op_private |= OPpENTERSUB_DB;
a0d0e21e 1296
312caa8e 1297 if (!(flags & G_EVAL)) {
0cdb2077 1298 CATCH_SET(TRUE);
864dbfa3 1299 call_xbody((OP*)&myop, FALSE);
312caa8e 1300 retval = PL_stack_sp - (PL_stack_base + oldmark);
0253cb41 1301 CATCH_SET(oldcatch);
312caa8e
CS		 1302 }
1303 else {
533c011a 1304 cLOGOP->op_other = PL_op;
3280af22 1305 PL_markstack_ptr--;
4633a7c4
LW		 1306 /* we're trying to emulate pp_entertry() here */
1307 {
c09156bb 1308 register PERL_CONTEXT *cx;
54310121 1309 I32 gimme = GIMME_V;
4633a7c4
LW		 1310
1311 ENTER;
1312 SAVETMPS;
1313
533c011a 1314 push_return(PL_op->op_next);
3280af22 1315 PUSHBLOCK(cx, CXt_EVAL, PL_stack_sp);
4633a7c4 1316 PUSHEVAL(cx, 0, 0);
533c011a 1317 PL_eval_root = PL_op; /* Only needed so that goto works right. */
4633a7c4 1318
faef0170 1319 PL_in_eval = EVAL_INEVAL;
4633a7c4 1320 if (flags & G_KEEPERR)
faef0170 1321 PL_in_eval |= EVAL_KEEPERR;
4633a7c4 1322 else
38a03e6e 1323 sv_setpv(ERRSV,"");
4633a7c4 1324 }
3280af22 1325 PL_markstack_ptr++;
a0d0e21e 1326
312caa8e 1327 redo_body:
db36c5a1
GS		 1328 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_call_body),
1329 (OP*)&myop, FALSE);
6224f72b
GS		 1330 switch (ret) {
1331 case 0:
312caa8e
CS		 1332 retval = PL_stack_sp - (PL_stack_base + oldmark);
1333 if (!(flags & G_KEEPERR))
1334 sv_setpv(ERRSV,"");
a0d0e21e 1335 break;
6224f72b 1336 case 1:
f86702cc 1337 STATUS_ALL_FAILURE;
a0d0e21e 1338 /* FALL THROUGH */
6224f72b 1339 case 2:
a0d0e21e 1340 /* my_exit() was called */
3280af22 1341 PL_curstash = PL_defstash;
a0d0e21e 1342 FREETMPS;
3280af22 1343 if (PL_statusvalue)
cea2e8a9 1344 Perl_croak(aTHX_ "Callback called exit");
f86702cc 1345 my_exit_jump();
a0d0e21e 1346 /* NOTREACHED */
6224f72b 1347 case 3:
3280af22 1348 if (PL_restartop) {
533c011a 1349 PL_op = PL_restartop;
3280af22 1350 PL_restartop = 0;
312caa8e 1351 goto redo_body;
a0d0e21e 1352 }
3280af22 1353 PL_stack_sp = PL_stack_base + oldmark;
a0d0e21e
LW		 1354 if (flags & G_ARRAY)
1355 retval = 0;
1356 else {
1357 retval = 1;
3280af22 1358 *++PL_stack_sp = &PL_sv_undef;
a0d0e21e 1359 }
312caa8e 1360 break;
a0d0e21e 1361 }
a0d0e21e 1362
3280af22 1363 if (PL_scopestack_ix > oldscope) {
a0a2876f
LW		 1364 SV **newsp;
1365 PMOP *newpm;
1366 I32 gimme;
c09156bb 1367 register PERL_CONTEXT *cx;
a0a2876f
LW		 1368 I32 optype;
1369
1370 POPBLOCK(cx,newpm);
1371 POPEVAL(cx);
1372 pop_return();
3280af22 1373 PL_curpm = newpm;
a0a2876f 1374 LEAVE;
a0d0e21e 1375 }
a0d0e21e 1376 }
1e422769 1377
a0d0e21e 1378 if (flags & G_DISCARD) {
3280af22 1379 PL_stack_sp = PL_stack_base + oldmark;
a0d0e21e
LW		 1380 retval = 0;
1381 FREETMPS;
1382 LEAVE;
1383 }
533c011a 1384 PL_op = oldop;
a0d0e21e
LW		 1385 return retval;
1386}
1387
312caa8e 1388STATIC void *
cea2e8a9 1389S_call_body(pTHX_ va_list args)
312caa8e
CS		 1390{
1391 OP *myop = va_arg(args, OP*);
1392 int is_eval = va_arg(args, int);
1393
864dbfa3 1394 call_xbody(myop, is_eval);
312caa8e
CS		 1395 return NULL;
1396}
1397
1398STATIC void
cea2e8a9 1399S_call_xbody(pTHX_ OP *myop, int is_eval)
312caa8e
CS		 1400{
1401 dTHR;
1402
1403 if (PL_op == myop) {
1404 if (is_eval)
cea2e8a9 1405 PL_op = Perl_pp_entereval(aTHX);
312caa8e 1406 else
cea2e8a9 1407 PL_op = Perl_pp_entersub(aTHX);
312caa8e
CS		 1408 }
1409 if (PL_op)
cea2e8a9 1410 CALLRUNOPS(aTHX);
312caa8e
CS		 1411}
1412
6e72f9df 1413/* Eval a string. The G_EVAL flag is always assumed. */
8990e307 1414
a0d0e21e 1415I32
864dbfa3 1416Perl_eval_sv(pTHX_ SV *sv, I32 flags)
8ac85365
NIS		 1417
1418 /* See G_* flags in cop.h */
a0d0e21e 1419{
924508f0 1420 dSP;
a0d0e21e 1421 UNOP myop; /* fake syntax tree node */
3280af22 1422 I32 oldmark = SP - PL_stack_base;
4633a7c4 1423 I32 retval;
4633a7c4 1424 I32 oldscope;
6224f72b 1425 int ret;
533c011a 1426 OP* oldop = PL_op;
db36c5a1 1427 dJMPENV;
84902520 1428
4633a7c4
LW		 1429 if (flags & G_DISCARD) {
1430 ENTER;
1431 SAVETMPS;
1432 }
1433
462e5cf6 1434 SAVEOP();
533c011a
NIS		 1435 PL_op = (OP*)&myop;
1436 Zero(PL_op, 1, UNOP);
3280af22
NIS		 1437 EXTEND(PL_stack_sp, 1);
1438 *++PL_stack_sp = sv;
1439 oldscope = PL_scopestack_ix;
79072805 1440
4633a7c4
LW		 1441 if (!(flags & G_NOARGS))
1442 myop.op_flags = OPf_STACKED;
79072805 1443 myop.op_next = Nullop;
6e72f9df 1444 myop.op_type = OP_ENTEREVAL;
54310121 1445 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1446 (flags & G_ARRAY) ? OPf_WANT_LIST :
1447 OPf_WANT_SCALAR);
6e72f9df 1448 if (flags & G_KEEPERR)
1449 myop.op_flags |= OPf_SPECIAL;
4633a7c4 1450
312caa8e 1451 redo_body:
db36c5a1
GS		 1452 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_call_body),
1453 (OP*)&myop, TRUE);
6224f72b
GS		 1454 switch (ret) {
1455 case 0:
312caa8e
CS		 1456 retval = PL_stack_sp - (PL_stack_base + oldmark);
1457 if (!(flags & G_KEEPERR))
1458 sv_setpv(ERRSV,"");
4633a7c4 1459 break;
6224f72b 1460 case 1:
f86702cc 1461 STATUS_ALL_FAILURE;
4633a7c4 1462 /* FALL THROUGH */
6224f72b 1463 case 2:
4633a7c4 1464 /* my_exit() was called */
3280af22 1465 PL_curstash = PL_defstash;
4633a7c4 1466 FREETMPS;
3280af22 1467 if (PL_statusvalue)
cea2e8a9 1468 Perl_croak(aTHX_ "Callback called exit");
f86702cc 1469 my_exit_jump();
4633a7c4 1470 /* NOTREACHED */
6224f72b 1471 case 3:
3280af22 1472 if (PL_restartop) {
533c011a 1473 PL_op = PL_restartop;
3280af22 1474 PL_restartop = 0;
312caa8e 1475 goto redo_body;
4633a7c4 1476 }
3280af22 1477 PL_stack_sp = PL_stack_base + oldmark;
4633a7c4
LW		 1478 if (flags & G_ARRAY)
1479 retval = 0;
1480 else {
1481 retval = 1;
3280af22 1482 *++PL_stack_sp = &PL_sv_undef;
4633a7c4 1483 }
312caa8e 1484 break;
4633a7c4
LW		 1485 }
1486
4633a7c4 1487 if (flags & G_DISCARD) {
3280af22 1488 PL_stack_sp = PL_stack_base + oldmark;
4633a7c4
LW		 1489 retval = 0;
1490 FREETMPS;
1491 LEAVE;
1492 }
533c011a 1493 PL_op = oldop;
4633a7c4
LW		 1494 return retval;
1495}
1496
137443ea 1497SV*
864dbfa3 1498Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
137443ea 1499{
1500 dSP;
1501 SV* sv = newSVpv(p, 0);
1502
924508f0 1503 PUSHMARK(SP);
864dbfa3 1504 eval_sv(sv, G_SCALAR);
137443ea 1505 SvREFCNT_dec(sv);
1506
1507 SPAGAIN;
1508 sv = POPs;
1509 PUTBACK;
1510
2d8e6c8d
GS		 1511 if (croak_on_error && SvTRUE(ERRSV)) {
1512 STRLEN n_a;
cea2e8a9 1513 Perl_croak(aTHX_ SvPVx(ERRSV, n_a));
2d8e6c8d 1514 }
137443ea 1515
1516 return sv;
1517}
1518
4633a7c4
LW		 1519/* Require a module. */
1520
1521void
864dbfa3 1522Perl_require_pv(pTHX_ const char *pv)
4633a7c4 1523{
d3acc0f7
JP		 1524 SV* sv;
1525 dSP;
e788e7d3 1526 PUSHSTACKi(PERLSI_REQUIRE);
d3acc0f7
JP		 1527 PUTBACK;
1528 sv = sv_newmortal();
4633a7c4
LW		 1529 sv_setpv(sv, "require '");
1530 sv_catpv(sv, pv);
1531 sv_catpv(sv, "'");
864dbfa3 1532 eval_sv(sv, G_DISCARD);
d3acc0f7
JP		 1533 SPAGAIN;
1534 POPSTACK;
79072805
LW		 1535}
1536
79072805 1537void
864dbfa3 1538Perl_magicname(pTHX_ char *sym, char *name, I32 namlen)
79072805
LW		 1539{
1540 register GV *gv;
1541
85e6fe83 1542 if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
79072805
LW		 1543 sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1544}
1545
76e3520e 1546STATIC void
cea2e8a9 1547S_usage(pTHX_ char *name) /* XXX move this out into a module ? */
4633a7c4 1548{
ab821d7f 1549 /* This message really ought to be max 23 lines.
1550 * Removed -h because the user already knows that opton. Others? */
fb73857a 1551
76e3520e 1552 static char *usage_msg[] = {
fb73857a 1553"-0[octal] specify record separator (\\0, if no argument)",
1554"-a autosplit mode with -n or -p (splits $_ into @F)",
1555"-c check syntax only (runs BEGIN and END blocks)",
aac3bd0d
GS		 1556"-d[:debugger] run program under debugger",
1557"-D[number/list] set debugging flags (argument is a bit mask or alphabets)",
1558"-e 'command' one line of program (several -e's allowed, omit programfile)",
1559"-F/pattern/ split() pattern for -a switch (//'s are optional)",
1560"-i[extension] edit <> files in place (makes backup if extension supplied)",
1561"-Idirectory specify @INC/#include directory (several -I's allowed)",
fb73857a 1562"-l[octal] enable line ending processing, specifies line terminator",
aac3bd0d
GS		 1563"-[mM][-]module execute `use/no module...' before executing program",
1564"-n assume 'while (<>) { ... }' loop around program",
1565"-p assume loop like -n but print line also, like sed",
1566"-P run program through C preprocessor before compilation",
1567"-s enable rudimentary parsing for switches after programfile",
1568"-S look for programfile using PATH environment variable",
1569"-T enable tainting checks",
1570"-u dump core after parsing program",
fb73857a 1571"-U allow unsafe operations",
aac3bd0d
GS		 1572"-v print version, subversion (includes VERY IMPORTANT perl info)",
1573"-V[:variable] print configuration summary (or a single Config.pm variable)",
1574"-w enable many useful warnings (RECOMMENDED)",
fb73857a 1575"-x[directory] strip off text before #!perl line and perhaps cd to directory",
1576"\n",
1577NULL
1578};
76e3520e 1579 char **p = usage_msg;
fb73857a 1580
ab821d7f 1581 printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
fb73857a 1582 while (*p)
1583 printf("\n %s", *p++);
4633a7c4
LW		 1584}
1585
79072805
LW		 1586/* This routine handles any switches that can be given during run */
1587
1588char *
864dbfa3 1589Perl_moreswitches(pTHX_ char *s)
79072805
LW		 1590{
1591 I32 numlen;
c07a80fd 1592 U32 rschar;
79072805
LW		 1593
1594 switch (*s) {
1595 case '0':
a863c7d1
MB		 1596 {
1597 dTHR;
dff6d3cd 1598 rschar = (U32)scan_oct(s, 4, &numlen);
3280af22 1599 SvREFCNT_dec(PL_nrs);
c07a80fd 1600 if (rschar & ~((U8)~0))
3280af22 1601 PL_nrs = &PL_sv_undef;
c07a80fd 1602 else if (!rschar && numlen >= 2)
79cb57f6 1603 PL_nrs = newSVpvn("", 0);
c07a80fd 1604 else {
1605 char ch = rschar;
79cb57f6 1606 PL_nrs = newSVpvn(&ch, 1);
79072805
LW		 1607 }
1608 return s + numlen;
a863c7d1 1609 }
2304df62 1610 case 'F':
3280af22
NIS		 1611 PL_minus_F = TRUE;
1612 PL_splitstr = savepv(s + 1);
2304df62
AD		 1613 s += strlen(s);
1614 return s;
79072805 1615 case 'a':
3280af22 1616 PL_minus_a = TRUE;
79072805
LW		 1617 s++;
1618 return s;
1619 case 'c':
3280af22 1620 PL_minus_c = TRUE;
79072805
LW		 1621 s++;
1622 return s;
1623 case 'd':
bbce6d69 1624 forbid_setid("-d");
4633a7c4 1625 s++;
c07a80fd 1626 if (*s == ':' || *s == '=') {
cea2e8a9 1627 my_setenv("PERL5DB", Perl_form(aTHX_ "use Devel::%s;", ++s));
4633a7c4 1628 s += strlen(s);
4633a7c4 1629 }
3280af22
NIS		 1630 if (!PL_perldb) {
1631 PL_perldb = PERLDB_ALL;
a0d0e21e
LW		 1632 init_debugger();
1633 }
79072805
LW		 1634 return s;
1635 case 'D':
0453d815 1636 {
79072805 1637#ifdef DEBUGGING
bbce6d69 1638 forbid_setid("-D");
79072805 1639 if (isALPHA(s[1])) {
8b73bbec 1640 static char debopts[] = "psltocPmfrxuLHXDS";
79072805
LW		 1641 char *d;
1642
93a17b20 1643 for (s++; *s && (d = strchr(debopts,*s)); s++)
3280af22 1644 PL_debug |= 1 << (d - debopts);
79072805
LW		 1645 }
1646 else {
3280af22 1647 PL_debug = atoi(s+1);
79072805
LW		 1648 for (s++; isDIGIT(*s); s++) ;
1649 }
3280af22 1650 PL_debug |= 0x80000000;
79072805 1651#else
0453d815
PM		 1652 dTHR;
1653 if (ckWARN_d(WARN_DEBUGGING))
1654 Perl_warner(aTHX_ WARN_DEBUGGING,
1655 "Recompile perl with -DDEBUGGING to use -D switch\n");
a0d0e21e 1656 for (s++; isALNUM(*s); s++) ;
79072805
LW		 1657#endif
1658 /*SUPPRESS 530*/
1659 return s;
0453d815 1660 }
4633a7c4 1661 case 'h':
3280af22 1662 usage(PL_origargv[0]);
6ad3d225 1663 PerlProc_exit(0);
79072805 1664 case 'i':
3280af22
NIS		 1665 if (PL_inplace)
1666 Safefree(PL_inplace);
1667 PL_inplace = savepv(s+1);
79072805 1668 /*SUPPRESS 530*/
3280af22 1669 for (s = PL_inplace; *s && !isSPACE(*s); s++) ;
7b8d334a 1670 if (*s) {
fb73857a 1671 *s++ = '\0';
7b8d334a
GS		 1672 if (*s == '-') /* Additional switches on #! line. */
1673 s++;
1674 }
fb73857a 1675 return s;
1676 case 'I': /* -I handled both here and in parse_perl() */
bbce6d69 1677 forbid_setid("-I");
fb73857a 1678 ++s;
1679 while (*s && isSPACE(*s))
1680 ++s;
1681 if (*s) {
774d564b 1682 char *e, *p;
748a9306 1683 for (e = s; *e && !isSPACE(*e); e++) ;
774d564b 1684 p = savepvn(s, e-s);
1685 incpush(p, TRUE);
1686 Safefree(p);
fb73857a 1687 s = e;
79072805
LW		 1688 }
1689 else
cea2e8a9 1690 Perl_croak(aTHX_ "No space allowed after -I");
fb73857a 1691 return s;
79072805 1692 case 'l':
3280af22 1693 PL_minus_l = TRUE;
79072805 1694 s++;
3280af22
NIS		 1695 if (PL_ors)
1696 Safefree(PL_ors);
79072805 1697 if (isDIGIT(*s)) {
3280af22
NIS		 1698 PL_ors = savepv("\n");
1699 PL_orslen = 1;
dff6d3cd 1700 *PL_ors = (char)scan_oct(s, 3 + (*s == '0'), &numlen);
79072805
LW		 1701 s += numlen;
1702 }
1703 else {
a863c7d1 1704 dTHR;
3280af22
NIS		 1705 if (RsPARA(PL_nrs)) {
1706 PL_ors = "\n\n";
1707 PL_orslen = 2;
c07a80fd 1708 }
1709 else
3280af22
NIS		 1710 PL_ors = SvPV(PL_nrs, PL_orslen);
1711 PL_ors = savepvn(PL_ors, PL_orslen);
79072805
LW		 1712 }
1713 return s;
1a30305b 1714 case 'M':
bbce6d69 1715 forbid_setid("-M"); /* XXX ? */
1a30305b 1716 /* FALL THROUGH */
1717 case 'm':
bbce6d69 1718 forbid_setid("-m"); /* XXX ? */
1a30305b 1719 if (*++s) {
a5f75d66 1720 char *start;
11343788 1721 SV *sv;
a5f75d66
AD		 1722 char *use = "use ";
1723 /* -M-foo == 'no foo' */
1724 if (*s == '-') { use = "no "; ++s; }
11343788 1725 sv = newSVpv(use,0);
a5f75d66 1726 start = s;
1a30305b 1727 /* We allow -M'Module qw(Foo Bar)' */
c07a80fd 1728 while(isALNUM(*s) || *s==':') ++s;
1729 if (*s != '=') {
11343788 1730 sv_catpv(sv, start);
c07a80fd 1731 if (*(start-1) == 'm') {
1732 if (*s != '\0')
cea2e8a9 1733 Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
11343788 1734 sv_catpv( sv, " ()");
c07a80fd 1735 }
1736 } else {
11343788
MB		 1737 sv_catpvn(sv, start, s-start);
1738 sv_catpv(sv, " split(/,/,q{");
1739 sv_catpv(sv, ++s);
1740 sv_catpv(sv, "})");
c07a80fd 1741 }
1a30305b 1742 s += strlen(s);
3280af22
NIS		 1743 if (PL_preambleav == NULL)
1744 PL_preambleav = newAV();
1745 av_push(PL_preambleav, sv);
1a30305b 1746 }
1747 else
cea2e8a9 1748 Perl_croak(aTHX_ "No space allowed after -%c", *(s-1));
1a30305b 1749 return s;
79072805 1750 case 'n':
3280af22 1751 PL_minus_n = TRUE;
79072805
LW		 1752 s++;
1753 return s;
1754 case 'p':
3280af22 1755 PL_minus_p = TRUE;
79072805
LW		 1756 s++;
1757 return s;
1758 case 's':
bbce6d69 1759 forbid_setid("-s");
3280af22 1760 PL_doswitches = TRUE;
79072805
LW		 1761 s++;
1762 return s;
463ee0b2 1763 case 'T':
3280af22 1764 if (!PL_tainting)
cea2e8a9 1765 Perl_croak(aTHX_ "Too late for \"-T\" option");
463ee0b2
LW		 1766 s++;
1767 return s;
79072805 1768 case 'u':
3280af22 1769 PL_do_undump = TRUE;
79072805
LW		 1770 s++;
1771 return s;
1772 case 'U':
3280af22 1773 PL_unsafe = TRUE;
79072805
LW		 1774 s++;
1775 return s;
1776 case 'v':
cceca5ed
GS		 1777#if defined(PERL_SUBVERSION) && PERL_SUBVERSION > 0
1778 printf("\nThis is perl, version %d.%03d_%02d built for %s",
1779 PERL_REVISION, PERL_VERSION, PERL_SUBVERSION, ARCHNAME);
a5f75d66 1780#else
fb73857a 1781 printf("\nThis is perl, version %s built for %s",
6b88bc9c 1782 PL_patchlevel, ARCHNAME);
fb73857a 1783#endif
1784#if defined(LOCAL_PATCH_COUNT)
1785 if (LOCAL_PATCH_COUNT > 0)
1786 printf("\n(with %d registered patch%s, see perl -V for more detail)",
b900a521 1787 (int)LOCAL_PATCH_COUNT, (LOCAL_PATCH_COUNT!=1) ? "es" : "");
a5f75d66 1788#endif
1a30305b 1789
4eb8286e 1790 printf("\n\nCopyright 1987-1999, Larry Wall\n");
79072805 1791#ifdef MSDOS
fb73857a 1792 printf("\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
55497cff 1793#endif
1794#ifdef DJGPP
1795 printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
4eb8286e 1796 printf("djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
4633a7c4 1797#endif
79072805 1798#ifdef OS2
5dd60ef7 1799 printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
4eb8286e 1800 "Version 5 port Copyright (c) 1994-1999, Andreas Kaiser, Ilya Zakharevich\n");
79072805 1801#endif
79072805 1802#ifdef atarist
760ac839 1803 printf("atariST series port, ++jrb bammi@cadence.com\n");
79072805 1804#endif
a3f9223b 1805#ifdef __BEOS__
4eb8286e 1806 printf("BeOS port Copyright Tom Spindler, 1997-1999\n");
a3f9223b 1807#endif
1d84e8df 1808#ifdef MPE
4eb8286e 1809 printf("MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-1999\n");
1d84e8df 1810#endif
9d116dd7 1811#ifdef OEMVS
4eb8286e 1812 printf("MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
9d116dd7 1813#endif
495c5fdc 1814#ifdef __VOS__
4eb8286e 1815 printf("Stratus VOS port by Paul_Green@stratus.com, 1997-1999\n");
495c5fdc 1816#endif
092bebab 1817#ifdef __OPEN_VM
4eb8286e 1818 printf("VM/ESA port by Neale Ferguson, 1998-1999\n");
092bebab 1819#endif
a1a0e61e 1820#ifdef POSIX_BC
4eb8286e 1821 printf("BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
a1a0e61e 1822#endif
61ae2fbf 1823#ifdef __MINT__
4eb8286e 1824 printf("MiNT port by Guido Flohr, 1997-1999\n");
61ae2fbf 1825#endif
baed7233
DL		 1826#ifdef BINARY_BUILD_NOTICE
1827 BINARY_BUILD_NOTICE;
1828#endif
760ac839 1829 printf("\n\
79072805 1830Perl may be copied only under the terms of either the Artistic License or the\n\
95103687
GS		 1831GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n\
1832Complete documentation for Perl, including FAQ lists, should be found on\n\
1833this system using `man perl' or `perldoc perl'. If you have access to the\n\
1834Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n");
6ad3d225 1835 PerlProc_exit(0);
79072805 1836 case 'w':
599cee73
PM		 1837 if (! (PL_dowarn & G_WARN_ALL_MASK))
1838 PL_dowarn |= G_WARN_ON;
1839 s++;
1840 return s;
1841 case 'W':
1842 PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
e24b16f9 1843 PL_compiling.cop_warnings = WARN_ALL ;
599cee73
PM		 1844 s++;
1845 return s;
1846 case 'X':
1847 PL_dowarn = G_WARN_ALL_OFF;
e24b16f9 1848 PL_compiling.cop_warnings = WARN_NONE ;
79072805
LW		 1849 s++;
1850 return s;
a0d0e21e 1851 case '*':
79072805
LW		 1852 case ' ':
1853 if (s[1] == '-') /* Additional switches on #! line. */
1854 return s+2;
1855 break;
a0d0e21e 1856 case '-':
79072805 1857 case 0:
51882d45 1858#if defined(WIN32) || !defined(PERL_STRICT_CR)
a868473f
NIS		 1859 case '\r':
1860#endif
79072805
LW		 1861 case '\n':
1862 case '\t':
1863 break;
aa689395 1864#ifdef ALTERNATE_SHEBANG
1865 case 'S': /* OS/2 needs -S on "extproc" line. */
1866 break;
1867#endif
a0d0e21e 1868 case 'P':
3280af22 1869 if (PL_preprocess)
a0d0e21e
LW		 1870 return s+1;
1871 /* FALL THROUGH */
79072805 1872 default:
cea2e8a9 1873 Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
79072805
LW		 1874 }
1875 return Nullch;
1876}
1877
1878/* compliments of Tom Christiansen */
1879
1880/* unexec() can be found in the Gnu emacs distribution */
ee580363 1881/* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
79072805
LW		 1882
1883void
864dbfa3 1884Perl_my_unexec(pTHX)
79072805
LW		 1885{
1886#ifdef UNEXEC
46fc3d4c 1887 SV* prog;
1888 SV* file;
ee580363 1889 int status = 1;
79072805
LW		 1890 extern int etext;
1891
ee580363 1892 prog = newSVpv(BIN_EXP, 0);
46fc3d4c 1893 sv_catpv(prog, "/perl");
6b88bc9c 1894 file = newSVpv(PL_origfilename, 0);
46fc3d4c 1895 sv_catpv(file, ".perldump");
79072805 1896
ee580363
GS		 1897 unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
1898 /* unexec prints msg to stderr in case of failure */
6ad3d225 1899 PerlProc_exit(status);
79072805 1900#else
a5f75d66
AD		 1901# ifdef VMS
1902# include <lib$routines.h>
1903 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
aa689395 1904# else
79072805 1905 ABORT(); /* for use with undump */
aa689395 1906# endif
a5f75d66 1907#endif
79072805
LW		 1908}
1909
cb68f92d
GS		 1910/* initialize curinterp */
1911STATIC void
cea2e8a9 1912S_init_interp(pTHX)
cb68f92d
GS		 1913{
1914
066ef5b5 1915#ifdef PERL_OBJECT /* XXX kludge */
cb68f92d 1916#define I_REINIT \
6b88bc9c
GS		 1917 STMT_START { \
1918 PL_chopset = " \n-"; \
1919 PL_copline = NOLINE; \
1920 PL_curcop = &PL_compiling;\
1921 PL_curcopdb = NULL; \
1922 PL_dbargs = 0; \
3967c732 1923 PL_dumpindent = 4; \
6b88bc9c
GS		 1924 PL_laststatval = -1; \
1925 PL_laststype = OP_STAT; \
1926 PL_maxscream = -1; \
1927 PL_maxsysfd = MAXSYSFD; \
1928 PL_statname = Nullsv; \
1929 PL_tmps_floor = -1; \
1930 PL_tmps_ix = -1; \
1931 PL_op_mask = NULL; \
6b88bc9c
GS		 1932 PL_laststatval = -1; \
1933 PL_laststype = OP_STAT; \
1934 PL_mess_sv = Nullsv; \
1935 PL_splitstr = " "; \
1936 PL_generation = 100; \
1937 PL_exitlist = NULL; \
1938 PL_exitlistlen = 0; \
1939 PL_regindent = 0; \
1940 PL_in_clean_objs = FALSE; \
1941 PL_in_clean_all = FALSE; \
1942 PL_profiledata = NULL; \
1943 PL_rsfp = Nullfp; \
1944 PL_rsfp_filters = Nullav; \
24d3c518 1945 PL_dirty = FALSE; \
cb68f92d 1946 } STMT_END
9666903d 1947 I_REINIT;
066ef5b5
GS		 1948#else
1949# ifdef MULTIPLICITY
1950# define PERLVAR(var,type)
51371543 1951# define PERLVARA(var,n,type)
cea2e8a9 1952# if defined(PERL_IMPLICIT_CONTEXT)
54aff467
GS		 1953# if defined(USE_THREADS)
1954# define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
1955# define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
1956# else /* !USE_THREADS */
1957# define PERLVARI(var,type,init) aTHX->var = init;
1958# define PERLVARIC(var,type,init) aTHX->var = init;
1959# endif /* USE_THREADS */
cea2e8a9 1960# else
c5be433b
GS		 1961# define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
1962# define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
cea2e8a9 1963# endif
066ef5b5
GS		 1964# include "intrpvar.h"
1965# ifndef USE_THREADS
1966# include "thrdvar.h"
1967# endif
1968# undef PERLVAR
51371543 1969# undef PERLVARA
066ef5b5
GS		 1970# undef PERLVARI
1971# undef PERLVARIC
3967c732 1972# else
066ef5b5 1973# define PERLVAR(var,type)
51371543 1974# define PERLVARA(var,n,type)
533c011a
NIS		 1975# define PERLVARI(var,type,init) PL_##var = init;
1976# define PERLVARIC(var,type,init) PL_##var = init;
066ef5b5
GS		 1977# include "intrpvar.h"
1978# ifndef USE_THREADS
1979# include "thrdvar.h"
1980# endif
1981# undef PERLVAR
51371543 1982# undef PERLVARA
066ef5b5
GS		 1983# undef PERLVARI
1984# undef PERLVARIC
1985# endif
cb68f92d
GS		 1986#endif
1987
cb68f92d
GS		 1988}
1989
76e3520e 1990STATIC void
cea2e8a9 1991S_init_main_stash(pTHX)
79072805 1992{
11343788 1993 dTHR;
463ee0b2 1994 GV *gv;
6e72f9df 1995
1996 /* Note that strtab is a rather special HV. Assumptions are made
1997 about not iterating on it, and not adding tie magic to it.
1998 It is properly deallocated in perl_destruct() */
3280af22 1999 PL_strtab = newHV();
5f08fbcd
GS		 2000#ifdef USE_THREADS
2001 MUTEX_INIT(&PL_strtab_mutex);
2002#endif
3280af22
NIS		 2003 HvSHAREKEYS_off(PL_strtab); /* mandatory */
2004 hv_ksplit(PL_strtab, 512);
6e72f9df 2005
3280af22 2006 PL_curstash = PL_defstash = newHV();
79cb57f6 2007 PL_curstname = newSVpvn("main",4);
adbc6bb1
LW		 2008 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
2009 SvREFCNT_dec(GvHV(gv));
3280af22 2010 GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);
463ee0b2 2011 SvREADONLY_on(gv);
3280af22
NIS		 2012 HvNAME(PL_defstash) = savepv("main");
2013 PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
2014 GvMULTI_on(PL_incgv);
2015 PL_hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */
2016 GvMULTI_on(PL_hintgv);
2017 PL_defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
2018 PL_errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
2019 GvMULTI_on(PL_errgv);
2020 PL_replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */
2021 GvMULTI_on(PL_replgv);
cea2e8a9 2022 (void)Perl_form(aTHX_ "%240s",""); /* Preallocate temp - for immediate signals. */
38a03e6e
MB		 2023 sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
2024 sv_setpvn(ERRSV, "", 0);
3280af22
NIS		 2025 PL_curstash = PL_defstash;
2026 PL_compiling.cop_stash = PL_defstash;
2027 PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
2028 PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
4633a7c4 2029 /* We must init $/ before switches are processed. */
864dbfa3 2030 sv_setpvn(get_sv("/", TRUE), "\n", 1);
79072805
LW		 2031}
2032
76e3520e 2033STATIC void
cea2e8a9 2034S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript)
79072805 2035{
0f15f207 2036 dTHR;
79072805 2037 register char *s;
2a92aaa0 2038
6c4ab083 2039 *fdscript = -1;
79072805 2040
3280af22
NIS		 2041 if (PL_e_script) {
2042 PL_origfilename = savepv("-e");
96436eeb 2043 }
6c4ab083
GS		 2044 else {
2045 /* if find_script() returns, it returns a malloc()-ed value */
3280af22 2046 PL_origfilename = scriptname = find_script(scriptname, dosearch, NULL, 1);
6c4ab083
GS		 2047
2048 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
2049 char *s = scriptname + 8;
2050 *fdscript = atoi(s);
2051 while (isDIGIT(*s))
2052 s++;
2053 if (*s) {
2054 scriptname = savepv(s + 1);
3280af22
NIS		 2055 Safefree(PL_origfilename);
2056 PL_origfilename = scriptname;
6c4ab083
GS		 2057 }
2058 }
2059 }
2060
cc49e20b 2061 CopFILEGV_set(PL_curcop, gv_fetchfile(PL_origfilename));
3280af22 2062 if (strEQ(PL_origfilename,"-"))
79072805 2063 scriptname = "";
01f988be 2064 if (*fdscript >= 0) {
3280af22 2065 PL_rsfp = PerlIO_fdopen(*fdscript,PERL_SCRIPT_MODE);
96436eeb 2066#if defined(HAS_FCNTL) && defined(F_SETFD)
3280af22
NIS		 2067 if (PL_rsfp)
2068 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1); /* ensure close-on-exec */
96436eeb 2069#endif
2070 }
3280af22 2071 else if (PL_preprocess) {
46fc3d4c 2072 char *cpp_cfg = CPPSTDIN;
79cb57f6 2073 SV *cpp = newSVpvn("",0);
46fc3d4c 2074 SV *cmd = NEWSV(0,0);
2075
2076 if (strEQ(cpp_cfg, "cppstdin"))
cea2e8a9 2077 Perl_sv_catpvf(aTHX_ cpp, "%s/", BIN_EXP);
46fc3d4c 2078 sv_catpv(cpp, cpp_cfg);
79072805 2079
79072805 2080 sv_catpv(sv,"-I");
fed7345c 2081 sv_catpv(sv,PRIVLIB_EXP);
46fc3d4c 2082
79072805 2083#ifdef MSDOS
cea2e8a9 2084 Perl_sv_setpvf(aTHX_ cmd, "\
79072805
LW		 2085sed %s -e \"/^[^#]/b\" \
2086 -e \"/^#[ ]*include[ ]/b\" \
2087 -e \"/^#[ ]*define[ ]/b\" \
2088 -e \"/^#[ ]*if[ ]/b\" \
2089 -e \"/^#[ ]*ifdef[ ]/b\" \
2090 -e \"/^#[ ]*ifndef[ ]/b\" \
2091 -e \"/^#[ ]*else/b\" \
2092 -e \"/^#[ ]*elif[ ]/b\" \
2093 -e \"/^#[ ]*undef[ ]/b\" \
2094 -e \"/^#[ ]*endif/b\" \
2095 -e \"s/^#.*//\" \
fc36a67e 2096 %s | %_ -C %_ %s",
6b88bc9c 2097 (PL_doextract ? "-e \"1,/^#/d\n\"" : ""),
79072805 2098#else
092bebab 2099# ifdef __OPEN_VM
cea2e8a9 2100 Perl_sv_setpvf(aTHX_ cmd, "\
092bebab
JH		 2101%s %s -e '/^[^#]/b' \
2102 -e '/^#[ ]*include[ ]/b' \
2103 -e '/^#[ ]*define[ ]/b' \
2104 -e '/^#[ ]*if[ ]/b' \
2105 -e '/^#[ ]*ifdef[ ]/b' \
2106 -e '/^#[ ]*ifndef[ ]/b' \
2107 -e '/^#[ ]*else/b' \
2108 -e '/^#[ ]*elif[ ]/b' \
2109 -e '/^#[ ]*undef[ ]/b' \
2110 -e '/^#[ ]*endif/b' \
2111 -e 's/^[ ]*#.*//' \
2112 %s | %_ %_ %s",
2113# else
cea2e8a9 2114 Perl_sv_setpvf(aTHX_ cmd, "\
79072805
LW		 2115%s %s -e '/^[^#]/b' \
2116 -e '/^#[ ]*include[ ]/b' \
2117 -e '/^#[ ]*define[ ]/b' \
2118 -e '/^#[ ]*if[ ]/b' \
2119 -e '/^#[ ]*ifdef[ ]/b' \
2120 -e '/^#[ ]*ifndef[ ]/b' \
2121 -e '/^#[ ]*else/b' \
2122 -e '/^#[ ]*elif[ ]/b' \
2123 -e '/^#[ ]*undef[ ]/b' \
2124 -e '/^#[ ]*endif/b' \
2125 -e 's/^[ ]*#.*//' \
fc36a67e 2126 %s | %_ -C %_ %s",
092bebab 2127# endif
79072805
LW		 2128#ifdef LOC_SED
2129 LOC_SED,
2130#else
2131 "sed",
2132#endif
3280af22 2133 (PL_doextract ? "-e '1,/^#/d\n'" : ""),
79072805 2134#endif
46fc3d4c 2135 scriptname, cpp, sv, CPPMINUS);
3280af22 2136 PL_doextract = FALSE;
79072805 2137#ifdef IAMSUID /* actually, this is caught earlier */
b28d0864 2138 if (PL_euid != PL_uid && !PL_euid) { /* if running suidperl */
79072805 2139#ifdef HAS_SETEUID
b28d0864 2140 (void)seteuid(PL_uid); /* musn't stay setuid root */
79072805
LW		 2141#else
2142#ifdef HAS_SETREUID
b28d0864 2143 (void)setreuid((Uid_t)-1, PL_uid);
85e6fe83
LW		 2144#else
2145#ifdef HAS_SETRESUID
b28d0864 2146 (void)setresuid((Uid_t)-1, PL_uid, (Uid_t)-1);
79072805 2147#else
b28d0864 2148 PerlProc_setuid(PL_uid);
79072805
LW		 2149#endif
2150#endif
85e6fe83 2151#endif
b28d0864 2152 if (PerlProc_geteuid() != PL_uid)
cea2e8a9 2153 Perl_croak(aTHX_ "Can't do seteuid!\n");
79072805
LW		 2154 }
2155#endif /* IAMSUID */
3280af22 2156 PL_rsfp = PerlProc_popen(SvPVX(cmd), "r");
46fc3d4c 2157 SvREFCNT_dec(cmd);
2158 SvREFCNT_dec(cpp);
79072805
LW		 2159 }
2160 else if (!*scriptname) {
bbce6d69 2161 forbid_setid("program input from stdin");
3280af22 2162 PL_rsfp = PerlIO_stdin();
79072805 2163 }
96436eeb 2164 else {
3280af22 2165 PL_rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
96436eeb 2166#if defined(HAS_FCNTL) && defined(F_SETFD)
3280af22
NIS		 2167 if (PL_rsfp)
2168 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1); /* ensure close-on-exec */
96436eeb 2169#endif
2170 }
3280af22 2171 if (!PL_rsfp) {
13281fa4 2172#ifdef DOSUID
a687059c 2173#ifndef IAMSUID /* in case script is not readable before setuid */
6b88bc9c 2174 if (PL_euid &&
cc49e20b 2175 PerlLIO_stat(CopFILE(PL_curcop),&PL_statbuf) >= 0 &&
6b88bc9c
GS		 2176 PL_statbuf.st_mode & (S_ISUID|S_ISGID))
2177 {
46fc3d4c 2178 /* try again */
cea2e8a9
GS		 2179 PerlProc_execv(Perl_form(aTHX_ "%s/sperl%s", BIN_EXP, PL_patchlevel), PL_origargv);
2180 Perl_croak(aTHX_ "Can't do setuid\n");
13281fa4
LW		 2181 }
2182#endif
2183#endif
cea2e8a9 2184 Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
cc49e20b 2185 CopFILE(PL_curcop), Strerror(errno));
13281fa4 2186 }
79072805 2187}
8d063cd8 2188
7b89560d
JH		 2189/* Mention
2190 * I_SYSSTATVFS HAS_FSTATVFS
2191 * I_SYSMOUNT
2192 * I_STATFS HAS_FSTATFS
2193 * I_MNTENT HAS_GETMNTENT HAS_HASMNTOPT
2194 * here so that metaconfig picks them up. */
2195
104d25b7 2196#ifdef IAMSUID
864dbfa3 2197STATIC int
e688b231 2198S_fd_on_nosuid_fs(pTHX_ int fd)
104d25b7 2199{
0545a864
JH		 2200 int check_okay = 0; /* able to do all the required sys/libcalls */
2201 int on_nosuid = 0; /* the fd is on a nosuid fs */
104d25b7 2202/*
ad27e871 2203 * Preferred order: fstatvfs(), fstatfs(), ustat()+getmnt(), getmntent().
e688b231 2204 * fstatvfs() is UNIX98.
0545a864 2205 * fstatfs() is 4.3 BSD.
ad27e871 2206 * ustat()+getmnt() is pre-4.3 BSD.
0545a864
JH		 2207 * getmntent() is O(number-of-mounted-filesystems) and can hang on
2208 * an irrelevant filesystem while trying to reach the right one.
104d25b7
JH		 2209 */
2210
2211# ifdef HAS_FSTATVFS
2212 struct statvfs stfs;
2213 check_okay = fstatvfs(fd, &stfs) == 0;
2214 on_nosuid = check_okay && (stfs.f_flag & ST_NOSUID);
2215# else
0545a864 2216# ifdef PERL_MOUNT_NOSUID
ad27e871
JH		 2217# if defined(HAS_FSTATFS) && \
2218 defined(HAS_STRUCT_STATFS) && \
2219 defined(HAS_STRUCT_STATFS_F_FLAGS)
e688b231 2220 struct statfs stfs;
104d25b7 2221 check_okay = fstatfs(fd, &stfs) == 0;
104d25b7 2222 on_nosuid = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID);
0545a864
JH		 2223# else
2224# if defined(HAS_FSTAT) && \
2225 defined(HAS_USTAT) && \
ad27e871
JH		 2226 defined(HAS_GETMNT) && \
2227 defined(HAS_STRUCT_FS_DATA) &&
2228 defined(NOSTAT_ONE)
0545a864
JH		 2229 struct stat fdst;
2230 if (fstat(fd, &fdst) == 0) {
2231 struct ustat us;
2232 if (ustat(fdst.st_dev, &us) == 0) {
2233 struct fs_data fsd;
ad27e871
JH		 2234 /* NOSTAT_ONE here because we're not examining fields which
2235 * vary between that case and STAT_ONE. */
2236 if (getmnt((int*)0, &fsd, (int)0, NOSTAT_ONE, us.f_fname) == 0) {
0545a864
JH		 2237 size_t cmplen = sizeof(us.f_fname);
2238 if (sizeof(fsd.fd_req.path) < cmplen)
2239 cmplen = sizeof(fsd.fd_req.path);
2240 if (strnEQ(fsd.fd_req.path, us.f_fname, cmplen) &&
2241 fdst.st_dev == fsd.fd_req.dev) {
2242 check_okay = 1;
2243 on_nosuid = fsd.fd_req.flags & PERL_MOUNT_NOSUID;
2244 }
2245 }
2246 }
2247 }
2248 }
ad27e871
JH		 2249# endif /* fstat+ustat+getmnt */
2250# endif /* fstatfs */
104d25b7 2251# else
0545a864
JH		 2252# if defined(HAS_GETMNTENT) && \
2253 defined(HAS_HASMNTOPT) && \
2254 defined(MNTOPT_NOSUID)
104d25b7
JH		 2255 FILE *mtab = fopen("/etc/mtab", "r");
2256 struct mntent *entry;
2257 struct stat stb, fsb;
2258
2259 if (mtab && (fstat(fd, &stb) == 0)) {
e688b231
JH		 2260 while (entry = getmntent(mtab)) {
2261 if (stat(entry->mnt_dir, &fsb) == 0
2262 && fsb.st_dev == stb.st_dev)
104d25b7
JH		 2263 {
2264 /* found the filesystem */
2265 check_okay = 1;
2266 if (hasmntopt(entry, MNTOPT_NOSUID))
2267 on_nosuid = 1;
2268 break;
e688b231 2269 } /* A single fs may well fail its stat(). */
104d25b7
JH		 2270 }
2271 }
2272 if (mtab)
2273 fclose(mtab);
ad27e871 2274# endif /* getmntent+hasmntopt */
0545a864 2275# endif /* PERL_MOUNT_NOSUID: fstatfs or fstat+ustat+statfs */
e688b231 2276# endif /* statvfs */
0545a864 2277
104d25b7 2278 if (!check_okay)
0545a864 2279 Perl_croak(aTHX_ "Can't check filesystem of script \"%s\" for nosuid", PL_origfilename);
104d25b7
JH		 2280 return on_nosuid;
2281}
2282#endif /* IAMSUID */
2283
76e3520e 2284STATIC void
cea2e8a9 2285S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript)
79072805 2286{
96436eeb 2287 int which;
2288
13281fa4
LW		 2289 /* do we need to emulate setuid on scripts? */
2290
2291 /* This code is for those BSD systems that have setuid #! scripts disabled
2292 * in the kernel because of a security problem. Merely defining DOSUID
2293 * in perl will not fix that problem, but if you have disabled setuid
2294 * scripts in the kernel, this will attempt to emulate setuid and setgid
2295 * on scripts that have those now-otherwise-useless bits set. The setuid
27e2fb84
LW		 2296 * root version must be called suidperl or sperlN.NNN. If regular perl
2297 * discovers that it has opened a setuid script, it calls suidperl with
2298 * the same argv that it had. If suidperl finds that the script it has
2299 * just opened is NOT setuid root, it sets the effective uid back to the
2300 * uid. We don't just make perl setuid root because that loses the
2301 * effective uid we had before invoking perl, if it was different from the
2302 * uid.
13281fa4
LW		 2303 *
2304 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
2305 * be defined in suidperl only. suidperl must be setuid root. The
2306 * Configure script will set this up for you if you want it.
2307 */
a687059c 2308
13281fa4 2309#ifdef DOSUID
ea0efc06 2310 dTHR;
6e72f9df 2311 char *s, *s2;
a0d0e21e 2312
b28d0864 2313 if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0) /* normal stat is insecure */
cea2e8a9 2314 Perl_croak(aTHX_ "Can't stat script \"%s\"",PL_origfilename);
b28d0864 2315 if (fdscript < 0 && PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
79072805 2316 I32 len;
2d8e6c8d 2317 STRLEN n_a;
13281fa4 2318
a687059c 2319#ifdef IAMSUID
fe14fcc3 2320#ifndef HAS_SETREUID
a687059c
LW		 2321 /* On this access check to make sure the directories are readable,
2322 * there is actually a small window that the user could use to make
2323 * filename point to an accessible directory. So there is a faint
2324 * chance that someone could execute a setuid script down in a
2325 * non-accessible directory. I don't know what to do about that.
2326 * But I don't think it's too important. The manual lies when
2327 * it says access() is useful in setuid programs.
2328 */
cc49e20b 2329 if (PerlLIO_access(CopFILE(PL_curcop),1)) /*double check*/
cea2e8a9 2330 Perl_croak(aTHX_ "Permission denied");
a687059c
LW		 2331#else
2332 /* If we can swap euid and uid, then we can determine access rights
2333 * with a simple stat of the file, and then compare device and
2334 * inode to make sure we did stat() on the same file we opened.
2335 * Then we just have to make sure he or she can execute it.
2336 */
2337 {
2338 struct stat tmpstatbuf;
2339
85e6fe83
LW		 2340 if (
2341#ifdef HAS_SETREUID
b28d0864 2342 setreuid(PL_euid,PL_uid) < 0
a0d0e21e
LW		 2343#else
2344# if HAS_SETRESUID
b28d0864 2345 setresuid(PL_euid,PL_uid,(Uid_t)-1) < 0
a0d0e21e 2346# endif
85e6fe83 2347#endif
b28d0864 2348 || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
cea2e8a9 2349 Perl_croak(aTHX_ "Can't swap uid and euid"); /* really paranoid */
cc49e20b 2350 if (PerlLIO_stat(CopFILE(PL_curcop),&tmpstatbuf) < 0)
cea2e8a9 2351 Perl_croak(aTHX_ "Permission denied"); /* testing full pathname here */
2bb3463c 2352#if defined(IAMSUID) && !defined(NO_NOSUID_CHECK)
e688b231 2353 if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp)))
cea2e8a9 2354 Perl_croak(aTHX_ "Permission denied");
104d25b7 2355#endif
b28d0864
NIS		 2356 if (tmpstatbuf.st_dev != PL_statbuf.st_dev ||
2357 tmpstatbuf.st_ino != PL_statbuf.st_ino) {
2358 (void)PerlIO_close(PL_rsfp);
2359 if (PL_rsfp = PerlProc_popen("/bin/mail root","w")) { /* heh, heh */
2360 PerlIO_printf(PL_rsfp,
785fb66b
JH		 2361"User %"Uid_t_f" tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
2362(Filename of set-id script was %s, uid %"Uid_t_f" gid %"Gid_t_f".)\n\nSincerely,\nperl\n",
2363 PL_uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
b28d0864 2364 (long)PL_statbuf.st_dev, (long)PL_statbuf.st_ino,
cc49e20b 2365 CopFILE(PL_curcop),
785fb66b 2366 PL_statbuf.st_uid, PL_statbuf.st_gid);
b28d0864 2367 (void)PerlProc_pclose(PL_rsfp);
a687059c 2368 }
cea2e8a9 2369 Perl_croak(aTHX_ "Permission denied\n");
a687059c 2370 }
85e6fe83
LW		 2371 if (
2372#ifdef HAS_SETREUID
b28d0864 2373 setreuid(PL_uid,PL_euid) < 0
a0d0e21e
LW		 2374#else
2375# if defined(HAS_SETRESUID)
b28d0864 2376 setresuid(PL_uid,PL_euid,(Uid_t)-1) < 0
a0d0e21e 2377# endif
85e6fe83 2378#endif
b28d0864 2379 || PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid)
cea2e8a9 2380 Perl_croak(aTHX_ "Can't reswap uid and euid");
b28d0864 2381 if (!cando(S_IXUSR,FALSE,&PL_statbuf)) /* can real uid exec? */
cea2e8a9 2382 Perl_croak(aTHX_ "Permission denied\n");
a687059c 2383 }
fe14fcc3 2384#endif /* HAS_SETREUID */
a687059c
LW		 2385#endif /* IAMSUID */
2386
b28d0864 2387 if (!S_ISREG(PL_statbuf.st_mode))
cea2e8a9 2388 Perl_croak(aTHX_ "Permission denied");
b28d0864 2389 if (PL_statbuf.st_mode & S_IWOTH)
cea2e8a9 2390 Perl_croak(aTHX_ "Setuid/gid script is writable by world");
6b88bc9c
GS		 2391 PL_doswitches = FALSE; /* -s is insecure in suid */
2392 PL_curcop->cop_line++;
2393 if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch ||
2d8e6c8d 2394 strnNE(SvPV(PL_linestr,n_a),"#!",2) ) /* required even on Sys V */
cea2e8a9 2395 Perl_croak(aTHX_ "No #! line");
2d8e6c8d 2396 s = SvPV(PL_linestr,n_a)+2;
663a0e37 2397 if (*s == ' ') s++;
45d8adaa 2398 while (!isSPACE(*s)) s++;
2d8e6c8d 2399 for (s2 = s; (s2 > SvPV(PL_linestr,n_a)+2 &&
6e72f9df 2400 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
2401 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
cea2e8a9 2402 Perl_croak(aTHX_ "Not a perl script");
a687059c 2403 while (*s == ' ' || *s == '\t') s++;
13281fa4
LW		 2404 /*
2405 * #! arg must be what we saw above. They can invoke it by
2406 * mentioning suidperl explicitly, but they may not add any strange
2407 * arguments beyond what #! says if they do invoke suidperl that way.
2408 */
2409 len = strlen(validarg);
2410 if (strEQ(validarg," PHOOEY ") ||
45d8adaa 2411 strnNE(s,validarg,len) || !isSPACE(s[len]))
cea2e8a9 2412 Perl_croak(aTHX_ "Args must match #! line");
a687059c
LW		 2413
2414#ifndef IAMSUID
b28d0864
NIS		 2415 if (PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
2416 PL_euid == PL_statbuf.st_uid)
2417 if (!PL_do_undump)
cea2e8a9 2418 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
a687059c
LW		 2419FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2420#endif /* IAMSUID */
13281fa4 2421
b28d0864
NIS		 2422 if (PL_euid) { /* oops, we're not the setuid root perl */
2423 (void)PerlIO_close(PL_rsfp);
13281fa4 2424#ifndef IAMSUID
46fc3d4c 2425 /* try again */
cea2e8a9 2426 PerlProc_execv(Perl_form(aTHX_ "%s/sperl%s", BIN_EXP, PL_patchlevel), PL_origargv);
13281fa4 2427#endif
cea2e8a9 2428 Perl_croak(aTHX_ "Can't do setuid\n");
13281fa4
LW		 2429 }
2430
b28d0864 2431 if (PL_statbuf.st_mode & S_ISGID && PL_statbuf.st_gid != PL_egid) {
fe14fcc3 2432#ifdef HAS_SETEGID
b28d0864 2433 (void)setegid(PL_statbuf.st_gid);
a687059c 2434#else
fe14fcc3 2435#ifdef HAS_SETREGID
b28d0864 2436 (void)setregid((Gid_t)-1,PL_statbuf.st_gid);
85e6fe83
LW		 2437#else
2438#ifdef HAS_SETRESGID
b28d0864 2439 (void)setresgid((Gid_t)-1,PL_statbuf.st_gid,(Gid_t)-1);
a687059c 2440#else
b28d0864 2441 PerlProc_setgid(PL_statbuf.st_gid);
a687059c
LW		 2442#endif
2443#endif
85e6fe83 2444#endif
b28d0864 2445 if (PerlProc_getegid() != PL_statbuf.st_gid)
cea2e8a9 2446 Perl_croak(aTHX_ "Can't do setegid!\n");
83025b21 2447 }
b28d0864
NIS		 2448 if (PL_statbuf.st_mode & S_ISUID) {
2449 if (PL_statbuf.st_uid != PL_euid)
fe14fcc3 2450#ifdef HAS_SETEUID
b28d0864 2451 (void)seteuid(PL_statbuf.st_uid); /* all that for this */
a687059c 2452#else
fe14fcc3 2453#ifdef HAS_SETREUID
b28d0864 2454 (void)setreuid((Uid_t)-1,PL_statbuf.st_uid);
85e6fe83
LW		 2455#else
2456#ifdef HAS_SETRESUID
b28d0864 2457 (void)setresuid((Uid_t)-1,PL_statbuf.st_uid,(Uid_t)-1);
a687059c 2458#else
b28d0864 2459 PerlProc_setuid(PL_statbuf.st_uid);
a687059c
LW		 2460#endif
2461#endif
85e6fe83 2462#endif
b28d0864 2463 if (PerlProc_geteuid() != PL_statbuf.st_uid)
cea2e8a9 2464 Perl_croak(aTHX_ "Can't do seteuid!\n");
a687059c 2465 }
b28d0864 2466 else if (PL_uid) { /* oops, mustn't run as root */
fe14fcc3 2467#ifdef HAS_SETEUID
b28d0864 2468 (void)seteuid((Uid_t)PL_uid);
a687059c 2469#else
fe14fcc3 2470#ifdef HAS_SETREUID
b28d0864 2471 (void)setreuid((Uid_t)-1,(Uid_t)PL_uid);
a687059c 2472#else
85e6fe83 2473#ifdef HAS_SETRESUID
b28d0864 2474 (void)setresuid((Uid_t)-1,(Uid_t)PL_uid,(Uid_t)-1);
85e6fe83 2475#else
b28d0864 2476 PerlProc_setuid((Uid_t)PL_uid);
85e6fe83 2477#endif
a687059c
LW		 2478#endif
2479#endif
b28d0864 2480 if (PerlProc_geteuid() != PL_uid)
cea2e8a9 2481 Perl_croak(aTHX_ "Can't do seteuid!\n");
83025b21 2482 }
748a9306 2483 init_ids();
b28d0864 2484 if (!cando(S_IXUSR,TRUE,&PL_statbuf))
cea2e8a9 2485 Perl_croak(aTHX_ "Permission denied\n"); /* they can't do this */
13281fa4
LW		 2486 }
2487#ifdef IAMSUID
6b88bc9c 2488 else if (PL_preprocess)
cea2e8a9 2489 Perl_croak(aTHX_ "-P not allowed for setuid/setgid script\n");
96436eeb 2490 else if (fdscript >= 0)
cea2e8a9 2491 Perl_croak(aTHX_ "fd script not allowed in suidperl\n");
13281fa4 2492 else
cea2e8a9 2493 Perl_croak(aTHX_ "Script is not setuid/setgid in suidperl\n");
96436eeb 2494
2495 /* We absolutely must clear out any saved ids here, so we */
2496 /* exec the real perl, substituting fd script for scriptname. */
2497 /* (We pass script name as "subdir" of fd, which perl will grok.) */
b28d0864
NIS		 2498 PerlIO_rewind(PL_rsfp);
2499 PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0); /* just in case rewind didn't */
6b88bc9c
GS		 2500 for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;
2501 if (!PL_origargv[which])
cea2e8a9
GS		 2502 Perl_croak(aTHX_ "Permission denied");
2503 PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s",
6b88bc9c 2504 PerlIO_fileno(PL_rsfp), PL_origargv[which]));
96436eeb 2505#if defined(HAS_FCNTL) && defined(F_SETFD)
b28d0864 2506 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0); /* ensure no close-on-exec */
96436eeb 2507#endif
cea2e8a9
GS		 2508 PerlProc_execv(Perl_form(aTHX_ "%s/perl%s", BIN_EXP, PL_patchlevel), PL_origargv);/* try again */
2509 Perl_croak(aTHX_ "Can't do setuid\n");
13281fa4 2510#endif /* IAMSUID */
a687059c 2511#else /* !DOSUID */
3280af22 2512 if (PL_euid != PL_uid || PL_egid != PL_gid) { /* (suidperl doesn't exist, in fact) */
a687059c 2513#ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
96827780 2514 dTHR;
b28d0864
NIS		 2515 PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf); /* may be either wrapped or real suid */
2516 if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
a687059c 2517 ||
b28d0864 2518 (PL_egid != PL_gid && PL_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
a687059c 2519 )
b28d0864 2520 if (!PL_do_undump)
cea2e8a9 2521 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
a687059c
LW		 2522FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2523#endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
2524 /* not set-id, must be wrapped */
a687059c 2525 }
13281fa4 2526#endif /* DOSUID */
79072805 2527}
13281fa4 2528
76e3520e 2529STATIC void
cea2e8a9 2530S_find_beginning(pTHX)
79072805 2531{
6e72f9df 2532 register char *s, *s2;
33b78306
LW		 2533
2534 /* skip forward in input to the real script? */
2535
bbce6d69 2536 forbid_setid("-x");
3280af22
NIS		 2537 while (PL_doextract) {
2538 if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch)
cea2e8a9 2539 Perl_croak(aTHX_ "No Perl script found in input\n");
6e72f9df 2540 if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
3280af22
NIS		 2541 PerlIO_ungetc(PL_rsfp, '\n'); /* to keep line count right */
2542 PL_doextract = FALSE;
6e72f9df 2543 while (*s && !(isSPACE (*s) || *s == '#')) s++;
2544 s2 = s;
2545 while (*s == ' ' || *s == '\t') s++;
2546 if (*s++ == '-') {
2547 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2548 if (strnEQ(s2-4,"perl",4))
2549 /*SUPPRESS 530*/
2550 while (s = moreswitches(s)) ;
33b78306 2551 }
83025b21
LW		 2552 }
2553 }
2554}
2555
afe37c7d 2556
76e3520e 2557STATIC void
cea2e8a9 2558S_init_ids(pTHX)
352d5a3a 2559{
d8eceb89
JH		 2560 PL_uid = PerlProc_getuid();
2561 PL_euid = PerlProc_geteuid();
2562 PL_gid = PerlProc_getgid();
2563 PL_egid = PerlProc_getegid();
748a9306 2564#ifdef VMS
b28d0864
NIS		 2565 PL_uid |= PL_gid << 16;
2566 PL_euid |= PL_egid << 16;
748a9306 2567#endif
3280af22 2568 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
748a9306 2569}
79072805 2570
76e3520e 2571STATIC void
cea2e8a9 2572S_forbid_setid(pTHX_ char *s)
bbce6d69 2573{
3280af22 2574 if (PL_euid != PL_uid)
cea2e8a9 2575 Perl_croak(aTHX_ "No %s allowed while running setuid", s);
3280af22 2576 if (PL_egid != PL_gid)
cea2e8a9 2577 Perl_croak(aTHX_ "No %s allowed while running setgid", s);
bbce6d69 2578}
2579
1ee4443e
IZ		 2580void
2581Perl_init_debugger(pTHX)
748a9306 2582{
11343788 2583 dTHR;
1ee4443e
IZ		 2584 HV *ostash = PL_curstash;
2585
3280af22
NIS		 2586 PL_curstash = PL_debstash;
2587 PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2588 AvREAL_off(PL_dbargs);
2589 PL_DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2590 PL_DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2591 PL_DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
1ee4443e 2592 sv_upgrade(GvSV(PL_DBsub), SVt_IV); /* IVX accessed if PERLDB_SUB_NN */
3280af22
NIS		 2593 PL_DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2594 sv_setiv(PL_DBsingle, 0);
2595 PL_DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2596 sv_setiv(PL_DBtrace, 0);
2597 PL_DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2598 sv_setiv(PL_DBsignal, 0);
1ee4443e 2599 PL_curstash = ostash;
352d5a3a
LW		 2600}
2601
2ce36478
SM		 2602#ifndef STRESS_REALLOC
2603#define REASONABLE(size) (size)
2604#else
2605#define REASONABLE(size) (1) /* unreasonable */
2606#endif
2607
11343788 2608void
cea2e8a9 2609Perl_init_stacks(pTHX)
79072805 2610{
e336de0d 2611 /* start with 128-item stack and 8K cxstack */
3280af22 2612 PL_curstackinfo = new_stackinfo(REASONABLE(128),
e336de0d 2613 REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
3280af22
NIS		 2614 PL_curstackinfo->si_type = PERLSI_MAIN;
2615 PL_curstack = PL_curstackinfo->si_stack;
2616 PL_mainstack = PL_curstack; /* remember in case we switch stacks */
79072805 2617
3280af22
NIS		 2618 PL_stack_base = AvARRAY(PL_curstack);
2619 PL_stack_sp = PL_stack_base;
2620 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
8990e307 2621
3280af22
NIS		 2622 New(50,PL_tmps_stack,REASONABLE(128),SV*);
2623 PL_tmps_floor = -1;
2624 PL_tmps_ix = -1;
2625 PL_tmps_max = REASONABLE(128);
8990e307 2626
3280af22
NIS		 2627 New(54,PL_markstack,REASONABLE(32),I32);
2628 PL_markstack_ptr = PL_markstack;
2629 PL_markstack_max = PL_markstack + REASONABLE(32);
79072805 2630
e336de0d
GS		 2631 SET_MARKBASE;
2632
3280af22
NIS		 2633 New(54,PL_scopestack,REASONABLE(32),I32);
2634 PL_scopestack_ix = 0;
2635 PL_scopestack_max = REASONABLE(32);
79072805 2636
3280af22
NIS		 2637 New(54,PL_savestack,REASONABLE(128),ANY);
2638 PL_savestack_ix = 0;
2639 PL_savestack_max = REASONABLE(128);
79072805 2640
3280af22
NIS		 2641 New(54,PL_retstack,REASONABLE(16),OP*);
2642 PL_retstack_ix = 0;
2643 PL_retstack_max = REASONABLE(16);
378cc40b 2644}
33b78306 2645
2ce36478
SM		 2646#undef REASONABLE
2647
76e3520e 2648STATIC void
cea2e8a9 2649S_nuke_stacks(pTHX)
6e72f9df 2650{
e858de61 2651 dTHR;
3280af22
NIS		 2652 while (PL_curstackinfo->si_next)
2653 PL_curstackinfo = PL_curstackinfo->si_next;
2654 while (PL_curstackinfo) {
2655 PERL_SI *p = PL_curstackinfo->si_prev;
bac4b2ad 2656 /* curstackinfo->si_stack got nuked by sv_free_arenas() */
3280af22
NIS		 2657 Safefree(PL_curstackinfo->si_cxstack);
2658 Safefree(PL_curstackinfo);
2659 PL_curstackinfo = p;
e336de0d 2660 }
3280af22
NIS		 2661 Safefree(PL_tmps_stack);
2662 Safefree(PL_markstack);
2663 Safefree(PL_scopestack);
2664 Safefree(PL_savestack);
2665 Safefree(PL_retstack);
378cc40b 2666}
33b78306 2667
76e3520e 2668#ifndef PERL_OBJECT
760ac839 2669static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
76e3520e 2670#endif
7aa04957 2671
76e3520e 2672STATIC void
cea2e8a9 2673S_init_lexer(pTHX)
8990e307 2674{
76e3520e
GS		 2675#ifdef PERL_OBJECT
2676 PerlIO *tmpfp;
2677#endif
3280af22
NIS		 2678 tmpfp = PL_rsfp;
2679 PL_rsfp = Nullfp;
2680 lex_start(PL_linestr);
2681 PL_rsfp = tmpfp;
79cb57f6 2682 PL_subname = newSVpvn("main",4);
8990e307
LW		 2683}
2684
76e3520e 2685STATIC void
cea2e8a9 2686S_init_predump_symbols(pTHX)
45d8adaa 2687{
11343788 2688 dTHR;
93a17b20 2689 GV *tmpgv;
a0d0e21e 2690 GV *othergv;
af8c498a 2691 IO *io;
79072805 2692
864dbfa3 2693 sv_setpvn(get_sv("\"", TRUE), " ", 1);
3280af22
NIS		 2694 PL_stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2695 GvMULTI_on(PL_stdingv);
af8c498a
GS		 2696 io = GvIOp(PL_stdingv);
2697 IoIFP(io) = PerlIO_stdin();
adbc6bb1 2698 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
a5f75d66 2699 GvMULTI_on(tmpgv);
af8c498a 2700 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
79072805 2701
85e6fe83 2702 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
a5f75d66 2703 GvMULTI_on(tmpgv);
af8c498a
GS		 2704 io = GvIOp(tmpgv);
2705 IoOFP(io) = IoIFP(io) = PerlIO_stdout();
4633a7c4 2706 setdefout(tmpgv);
adbc6bb1 2707 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
a5f75d66 2708 GvMULTI_on(tmpgv);
af8c498a 2709 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
79072805 2710
bf49b057
GS		 2711 PL_stderrgv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2712 GvMULTI_on(PL_stderrgv);
2713 io = GvIOp(PL_stderrgv);
af8c498a 2714 IoOFP(io) = IoIFP(io) = PerlIO_stderr();
adbc6bb1 2715 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
a5f75d66 2716 GvMULTI_on(tmpgv);
af8c498a 2717 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
79072805 2718
3280af22 2719 PL_statname = NEWSV(66,0); /* last filename we did stat on */
ab821d7f 2720
3280af22
NIS		 2721 if (!PL_osname)
2722 PL_osname = savepv(OSNAME);
79072805 2723}
33b78306 2724
76e3520e 2725STATIC void
cea2e8a9 2726S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
33b78306 2727{
a863c7d1 2728 dTHR;
79072805
LW		 2729 char *s;
2730 SV *sv;
2731 GV* tmpgv;
fe14fcc3 2732
79072805 2733 argc--,argv++; /* skip name of script */
3280af22 2734 if (PL_doswitches) {
79072805
LW		 2735 for (; argc > 0 && **argv == '-'; argc--,argv++) {
2736 if (!argv[0][1])
2737 break;
2738 if (argv[0][1] == '-') {
2739 argc--,argv++;
2740 break;
2741 }
93a17b20 2742 if (s = strchr(argv[0], '=')) {
79072805 2743 *s++ = '\0';
85e6fe83 2744 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
79072805
LW		 2745 }
2746 else
85e6fe83 2747 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
fe14fcc3 2748 }
79072805 2749 }
3280af22
NIS		 2750 PL_toptarget = NEWSV(0,0);
2751 sv_upgrade(PL_toptarget, SVt_PVFM);
2752 sv_setpvn(PL_toptarget, "", 0);
2753 PL_bodytarget = NEWSV(0,0);
2754 sv_upgrade(PL_bodytarget, SVt_PVFM);
2755 sv_setpvn(PL_bodytarget, "", 0);
2756 PL_formtarget = PL_bodytarget;
79072805 2757
bbce6d69 2758 TAINT;
85e6fe83 2759 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
3280af22 2760 sv_setpv(GvSV(tmpgv),PL_origfilename);
79072805
LW		 2761 magicname("0", "0", 1);
2762 }
85e6fe83 2763 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
ed344e4f
IZ		 2764#ifdef OS2
2765 sv_setpv(GvSV(tmpgv), os2_execname());
2766#else
3280af22 2767 sv_setpv(GvSV(tmpgv),PL_origargv[0]);
ed344e4f 2768#endif
3280af22
NIS		 2769 if (PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2770 GvMULTI_on(PL_argvgv);
2771 (void)gv_AVadd(PL_argvgv);
2772 av_clear(GvAVn(PL_argvgv));
79072805 2773 for (; argc > 0; argc--,argv++) {
3280af22 2774 av_push(GvAVn(PL_argvgv),newSVpv(argv[0],0));
79072805
LW		 2775 }
2776 }
3280af22 2777 if (PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
79072805 2778 HV *hv;
3280af22
NIS		 2779 GvMULTI_on(PL_envgv);
2780 hv = GvHVn(PL_envgv);
2781 hv_magic(hv, PL_envgv, 'E');
4d2c4e07 2782#if !defined( VMS) && !defined(EPOC) /* VMS doesn't have environ array */
4633a7c4
LW		 2783 /* Note that if the supplied env parameter is actually a copy
2784 of the global environ then it may now point to free'd memory
2785 if the environment has been modified since. To avoid this
2786 problem we treat env==NULL as meaning 'use the default'
2787 */
2788 if (!env)
2789 env = environ;
5aabfad6 2790 if (env != environ)
79072805
LW		 2791 environ[0] = Nullch;
2792 for (; *env; env++) {
93a17b20 2793 if (!(s = strchr(*env,'=')))
79072805
LW		 2794 continue;
2795 *s++ = '\0';
60ce6247 2796#if defined(MSDOS)
137443ea 2797 (void)strupr(*env);
2798#endif
79072805
LW		 2799 sv = newSVpv(s--,0);
2800 (void)hv_store(hv, *env, s - *env, sv, 0);
2801 *s = '=';
3e3baf6d
TB		 2802#if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV)
2803 /* Sins of the RTL. See note in my_setenv(). */
76e3520e 2804 (void)PerlEnv_putenv(savepv(*env));
3e3baf6d 2805#endif
fe14fcc3 2806 }
4550b24a 2807#endif
2808#ifdef DYNAMIC_ENV_FETCH
2809 HvNAME(hv) = savepv(ENV_HV_NAME);
2810#endif
79072805 2811 }
bbce6d69 2812 TAINT_NOT;
85e6fe83 2813 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
1e422769 2814 sv_setiv(GvSV(tmpgv), (IV)getpid());
33b78306 2815}
34de22dd 2816
76e3520e 2817STATIC void
cea2e8a9 2818S_init_perllib(pTHX)
34de22dd 2819{
85e6fe83 2820 char *s;
3280af22 2821 if (!PL_tainting) {
552a7a9b 2822#ifndef VMS
76e3520e 2823 s = PerlEnv_getenv("PERL5LIB");
85e6fe83 2824 if (s)
774d564b 2825 incpush(s, TRUE);
85e6fe83 2826 else
76e3520e 2827 incpush(PerlEnv_getenv("PERLLIB"), FALSE);
552a7a9b 2828#else /* VMS */
2829 /* Treat PERL5?LIB as a possible search list logical name -- the
2830 * "natural" VMS idiom for a Unix path string. We allow each
2831 * element to be a set of |-separated directories for compatibility.
2832 */
2833 char buf[256];
2834 int idx = 0;
2835 if (my_trnlnm("PERL5LIB",buf,0))
774d564b 2836 do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
552a7a9b 2837 else
774d564b 2838 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
552a7a9b 2839#endif /* VMS */
85e6fe83 2840 }
34de22dd 2841
c90c0ff4 2842/* Use the ~-expanded versions of APPLLIB (undocumented),
dfe9444c 2843 ARCHLIB PRIVLIB SITEARCH and SITELIB
df5cef82 2844*/
4633a7c4 2845#ifdef APPLLIB_EXP
43051805 2846 incpush(APPLLIB_EXP, TRUE);
16d20bd9 2847#endif
4633a7c4 2848
fed7345c 2849#ifdef ARCHLIB_EXP
774d564b 2850 incpush(ARCHLIB_EXP, FALSE);
a0d0e21e 2851#endif
fed7345c
AD		 2852#ifndef PRIVLIB_EXP
2853#define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
34de22dd 2854#endif
00dc2f4f
GS		 2855#if defined(WIN32)
2856 incpush(PRIVLIB_EXP, TRUE);
2857#else
774d564b 2858 incpush(PRIVLIB_EXP, FALSE);
00dc2f4f 2859#endif
4633a7c4
LW		 2860
2861#ifdef SITEARCH_EXP
774d564b 2862 incpush(SITEARCH_EXP, FALSE);
4633a7c4
LW		 2863#endif
2864#ifdef SITELIB_EXP
00dc2f4f
GS		 2865#if defined(WIN32)
2866 incpush(SITELIB_EXP, TRUE);
2867#else
774d564b 2868 incpush(SITELIB_EXP, FALSE);
4633a7c4 2869#endif
81c6dfba 2870#endif
a3635516
JH		 2871#if defined(PERL_VENDORLIB_EXP)
2872#if defined(WIN32)
265f5c4a 2873 incpush(PERL_VENDORLIB_EXP, TRUE);
a3635516
JH		 2874#else
2875 incpush(PERL_VENDORLIB_EXP, FALSE);
2876#endif
00dc2f4f 2877#endif
3280af22 2878 if (!PL_tainting)
774d564b 2879 incpush(".", FALSE);
2880}
2881
2882#if defined(DOSISH)
2883# define PERLLIB_SEP ';'
2884#else
2885# if defined(VMS)
2886# define PERLLIB_SEP '|'
2887# else
2888# define PERLLIB_SEP ':'
2889# endif
2890#endif
2891#ifndef PERLLIB_MANGLE
2892# define PERLLIB_MANGLE(s,n) (s)
2893#endif
2894
76e3520e 2895STATIC void
cea2e8a9 2896S_incpush(pTHX_ char *p, int addsubdirs)
774d564b 2897{
2898 SV *subdir = Nullsv;
774d564b 2899
2900 if (!p)
2901 return;
2902
2903 if (addsubdirs) {
00db4c45 2904 subdir = sv_newmortal();
3280af22
NIS		 2905 if (!PL_archpat_auto) {
2906 STRLEN len = (sizeof(ARCHNAME) + strlen(PL_patchlevel)
774d564b 2907 + sizeof("//auto"));
3280af22
NIS		 2908 New(55, PL_archpat_auto, len, char);
2909 sprintf(PL_archpat_auto, "/%s/%s/auto", ARCHNAME, PL_patchlevel);
aa689395 2910#ifdef VMS
2911 for (len = sizeof(ARCHNAME) + 2;
6b88bc9c
GS		 2912 PL_archpat_auto[len] != '\0' && PL_archpat_auto[len] != '/'; len++)
2913 if (PL_archpat_auto[len] == '.') PL_archpat_auto[len] = '_';
aa689395 2914#endif
774d564b 2915 }
2916 }
2917
2918 /* Break at all separators */
2919 while (p && *p) {
8c52afec 2920 SV *libdir = NEWSV(55,0);
774d564b 2921 char *s;
2922
2923 /* skip any consecutive separators */
2924 while ( *p == PERLLIB_SEP ) {
2925 /* Uncomment the next line for PATH semantics */
79cb57f6 2926 /* av_push(GvAVn(PL_incgv), newSVpvn(".", 1)); */
774d564b 2927 p++;
2928 }
2929
2930 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
2931 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
2932 (STRLEN)(s - p));
2933 p = s + 1;
2934 }
2935 else {
2936 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
2937 p = Nullch; /* break out */
2938 }
2939
2940 /*
2941 * BEFORE pushing libdir onto @INC we may first push version- and
2942 * archname-specific sub-directories.
2943 */
2944 if (addsubdirs) {
2945 struct stat tmpstatbuf;
aa689395 2946#ifdef VMS
2947 char *unix;
2948 STRLEN len;
774d564b 2949
2d8e6c8d 2950 if ((unix = tounixspec_ts(SvPV(libdir,len),Nullch)) != Nullch) {
aa689395 2951 len = strlen(unix);
2952 while (unix[len-1] == '/') len--; /* Cosmetic */
2953 sv_usepvn(libdir,unix,len);
2954 }
2955 else
bf49b057 2956 PerlIO_printf(Perl_error_log,
aa689395 2957 "Failed to unixify @INC element \"%s\"\n",
2d8e6c8d 2958 SvPV(libdir,len));
aa689395 2959#endif
4fdae800 2960 /* .../archname/version if -d .../archname/version/auto */
774d564b 2961 sv_setsv(subdir, libdir);
3280af22 2962 sv_catpv(subdir, PL_archpat_auto);
76e3520e 2963 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
774d564b 2964 S_ISDIR(tmpstatbuf.st_mode))
3280af22 2965 av_push(GvAVn(PL_incgv),
79cb57f6 2966 newSVpvn(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
774d564b 2967
4fdae800 2968 /* .../archname if -d .../archname/auto */
774d564b 2969 sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
3280af22 2970 strlen(PL_patchlevel) + 1, "", 0);
76e3520e 2971 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
774d564b 2972 S_ISDIR(tmpstatbuf.st_mode))
3280af22 2973 av_push(GvAVn(PL_incgv),
79cb57f6 2974 newSVpvn(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
774d564b 2975 }
2976
2977 /* finally push this lib directory on the end of @INC */
3280af22 2978 av_push(GvAVn(PL_incgv), libdir);
774d564b 2979 }
34de22dd 2980}
93a17b20 2981
199100c8 2982#ifdef USE_THREADS
76e3520e 2983STATIC struct perl_thread *
cea2e8a9 2984S_init_main_thread(pTHX)
199100c8 2985{
c5be433b 2986#if !defined(PERL_IMPLICIT_CONTEXT)
52e1cb5e 2987 struct perl_thread *thr;
cea2e8a9 2988#endif
199100c8
MB		 2989 XPV *xpv;
2990
52e1cb5e 2991 Newz(53, thr, 1, struct perl_thread);
533c011a 2992 PL_curcop = &PL_compiling;
c5be433b 2993 thr->interp = PERL_GET_INTERP;
199100c8 2994 thr->cvcache = newHV();
54b9620d 2995 thr->threadsv = newAV();
940cb80d 2996 /* thr->threadsvp is set when find_threadsv is called */
199100c8
MB		 2997 thr->specific = newAV();
2998 thr->flags = THRf_R_JOINABLE;
2999 MUTEX_INIT(&thr->mutex);
3000 /* Handcraft thrsv similarly to mess_sv */
533c011a 3001 New(53, PL_thrsv, 1, SV);
199100c8 3002 Newz(53, xpv, 1, XPV);
533c011a
NIS		 3003 SvFLAGS(PL_thrsv) = SVt_PV;
3004 SvANY(PL_thrsv) = (void*)xpv;
3005 SvREFCNT(PL_thrsv) = 1 << 30; /* practically infinite */
3006 SvPVX(PL_thrsv) = (char*)thr;
3007 SvCUR_set(PL_thrsv, sizeof(thr));
3008 SvLEN_set(PL_thrsv, sizeof(thr));
3009 *SvEND(PL_thrsv) = '\0'; /* in the trailing_nul field */
3010 thr->oursv = PL_thrsv;
3011 PL_chopset = " \n-";
3967c732 3012 PL_dumpindent = 4;
533c011a
NIS		 3013
3014 MUTEX_LOCK(&PL_threads_mutex);
3015 PL_nthreads++;
199100c8
MB		 3016 thr->tid = 0;
3017 thr->next = thr;
3018 thr->prev = thr;
533c011a 3019 MUTEX_UNLOCK(&PL_threads_mutex);
199100c8 3020
4b026b9e 3021#ifdef HAVE_THREAD_INTERN
4f63d024 3022 Perl_init_thread_intern(thr);
235db74f
GS		 3023#endif
3024
3025#ifdef SET_THREAD_SELF
3026 SET_THREAD_SELF(thr);
199100c8
MB		 3027#else
3028 thr->self = pthread_self();
235db74f 3029#endif /* SET_THREAD_SELF */
199100c8
MB		 3030 SET_THR(thr);
3031
3032 /*
3033 * These must come after the SET_THR because sv_setpvn does
3034 * SvTAINT and the taint fields require dTHR.
3035 */
533c011a
NIS		 3036 PL_toptarget = NEWSV(0,0);
3037 sv_upgrade(PL_toptarget, SVt_PVFM);
3038 sv_setpvn(PL_toptarget, "", 0);
3039 PL_bodytarget = NEWSV(0,0);
3040 sv_upgrade(PL_bodytarget, SVt_PVFM);
3041 sv_setpvn(PL_bodytarget, "", 0);
3042 PL_formtarget = PL_bodytarget;
79cb57f6 3043 thr->errsv = newSVpvn("", 0);
78857c3c 3044 (void) find_threadsv("@"); /* Ensure $@ is initialised early */
5c0ca799 3045
533c011a 3046 PL_maxscream = -1;
0b94c7bb
GS		 3047 PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp);
3048 PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags);
3049 PL_regint_start = MEMBER_TO_FPTR(Perl_re_intuit_start);
3050 PL_regint_string = MEMBER_TO_FPTR(Perl_re_intuit_string);
3051 PL_regfree = MEMBER_TO_FPTR(Perl_pregfree);
533c011a
NIS		 3052 PL_regindent = 0;
3053 PL_reginterp_cnt = 0;
5c0ca799 3054
199100c8
MB		 3055 return thr;
3056}
3057#endif /* USE_THREADS */
3058
93a17b20 3059void
864dbfa3 3060Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
93a17b20 3061{
11343788 3062 dTHR;
312caa8e 3063 SV *atsv = ERRSV;
3280af22 3064 line_t oldline = PL_curcop->cop_line;
312caa8e 3065 CV *cv;
22921e25 3066 STRLEN len;
6224f72b 3067 int ret;
db36c5a1 3068 dJMPENV;
93a17b20 3069
76e3520e 3070 while (AvFILL(paramList) >= 0) {
312caa8e 3071 cv = (CV*)av_shift(paramList);
8990e307 3072 SAVEFREESV(cv);
db36c5a1 3073 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_call_list_body), cv);
6224f72b 3074 switch (ret) {
312caa8e
CS		 3075 case 0:
3076 (void)SvPV(atsv, len);
3077 if (len) {
3078 PL_curcop = &PL_compiling;
3079 PL_curcop->cop_line = oldline;
3080 if (paramList == PL_beginav)
3081 sv_catpv(atsv, "BEGIN failed--compilation aborted");
3082 else
4f25aa18
GS		 3083 Perl_sv_catpvf(aTHX_ atsv,
3084 "%s failed--call queue aborted",
3085 paramList == PL_stopav ? "STOP"
3086 : paramList == PL_initav ? "INIT"
3087 : "END");
312caa8e
CS		 3088 while (PL_scopestack_ix > oldscope)
3089 LEAVE;
cea2e8a9 3090 Perl_croak(aTHX_ "%s", SvPVX(atsv));
a0d0e21e 3091 }
85e6fe83 3092 break;
6224f72b 3093 case 1:
f86702cc 3094 STATUS_ALL_FAILURE;
85e6fe83 3095 /* FALL THROUGH */
6224f72b 3096 case 2:
85e6fe83 3097 /* my_exit() was called */
3280af22 3098 while (PL_scopestack_ix > oldscope)
2ae324a7 3099 LEAVE;
84902520 3100 FREETMPS;
3280af22 3101 PL_curstash = PL_defstash;
3280af22
NIS		 3102 PL_curcop = &PL_compiling;
3103 PL_curcop->cop_line = oldline;
3104 if (PL_statusvalue) {
3105 if (paramList == PL_beginav)
cea2e8a9 3106 Perl_croak(aTHX_ "BEGIN failed--compilation aborted");
85e6fe83 3107 else
4f25aa18
GS		 3108 Perl_croak(aTHX_ "%s failed--call queue aborted",
3109 paramList == PL_stopav ? "STOP"
3110 : paramList == PL_initav ? "INIT"
3111 : "END");
85e6fe83 3112 }
f86702cc 3113 my_exit_jump();
85e6fe83 3114 /* NOTREACHED */
6224f72b 3115 case 3:
312caa8e
CS		 3116 if (PL_restartop) {
3117 PL_curcop = &PL_compiling;
3118 PL_curcop->cop_line = oldline;
3119 JMPENV_JUMP(3);
85e6fe83 3120 }
bf49b057 3121 PerlIO_printf(Perl_error_log, "panic: restartop\n");
312caa8e
CS		 3122 FREETMPS;
3123 break;
8990e307 3124 }
93a17b20 3125 }
93a17b20 3126}
93a17b20 3127
312caa8e 3128STATIC void *
cea2e8a9 3129S_call_list_body(pTHX_ va_list args)
312caa8e
CS		 3130{
3131 dTHR;
3132 CV *cv = va_arg(args, CV*);
3133
3134 PUSHMARK(PL_stack_sp);
864dbfa3 3135 call_sv((SV*)cv, G_EVAL|G_DISCARD);
312caa8e
CS		 3136 return NULL;
3137}
3138
f86702cc 3139void
864dbfa3 3140Perl_my_exit(pTHX_ U32 status)
f86702cc 3141{
5dc0d613
MB		 3142 dTHR;
3143
8b73bbec 3144 DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
a863c7d1 3145 thr, (unsigned long) status));
f86702cc 3146 switch (status) {
3147 case 0:
3148 STATUS_ALL_SUCCESS;
3149 break;
3150 case 1:
3151 STATUS_ALL_FAILURE;
3152 break;
3153 default:
3154 STATUS_NATIVE_SET(status);
3155 break;
3156 }
3157 my_exit_jump();
3158}
3159
3160void
864dbfa3 3161Perl_my_failure_exit(pTHX)
f86702cc 3162{
3163#ifdef VMS
3164 if (vaxc$errno & 1) {
4fdae800 3165 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
3166 STATUS_NATIVE_SET(44);
f86702cc 3167 }
3168 else {
ff0cee69 3169 if (!vaxc$errno && errno) /* unlikely */
4fdae800 3170 STATUS_NATIVE_SET(44);
f86702cc 3171 else
4fdae800 3172 STATUS_NATIVE_SET(vaxc$errno);
f86702cc 3173 }
3174#else
9b599b2a 3175 int exitstatus;
f86702cc 3176 if (errno & 255)
3177 STATUS_POSIX_SET(errno);
9b599b2a
GS		 3178 else {
3179 exitstatus = STATUS_POSIX >> 8;
3180 if (exitstatus & 255)
3181 STATUS_POSIX_SET(exitstatus);
3182 else
3183 STATUS_POSIX_SET(255);
3184 }
f86702cc 3185#endif
3186 my_exit_jump();
93a17b20
LW		 3187}
3188
76e3520e 3189STATIC void
cea2e8a9 3190S_my_exit_jump(pTHX)
f86702cc 3191{
de616352 3192 dTHR;
c09156bb 3193 register PERL_CONTEXT *cx;
f86702cc 3194 I32 gimme;
3195 SV **newsp;
3196
3280af22
NIS		 3197 if (PL_e_script) {
3198 SvREFCNT_dec(PL_e_script);
3199 PL_e_script = Nullsv;
f86702cc 3200 }
3201
3280af22 3202 POPSTACK_TO(PL_mainstack);
f86702cc 3203 if (cxstack_ix >= 0) {
3204 if (cxstack_ix > 0)
3205 dounwind(0);
3280af22 3206 POPBLOCK(cx,PL_curpm);
f86702cc 3207 LEAVE;
3208 }
ff0cee69 3209
6224f72b 3210 JMPENV_JUMP(2);
f86702cc 3211}
873ef191 3212
7a5f8e82 3213#ifdef PERL_OBJECT
873ef191 3214#include "XSUB.h"
51371543 3215#endif
873ef191 3216
0cb96387
GS		 3217static I32
3218read_e_script(pTHXo_ int idx, SV *buf_sv, int maxlen)
873ef191
GS		 3219{
3220 char *p, *nl;
3280af22 3221 p = SvPVX(PL_e_script);
873ef191 3222 nl = strchr(p, '\n');
3280af22 3223 nl = (nl) ? nl+1 : SvEND(PL_e_script);
7dfe3f66 3224 if (nl-p == 0) {
0cb96387 3225 filter_del(read_e_script);
873ef191 3226 return 0;
7dfe3f66 3227 }
873ef191 3228 sv_catpvn(buf_sv, p, nl-p);
3280af22 3229 sv_chop(PL_e_script, nl);
873ef191
GS		 3230 return 1;
3231}
3232
Unnamed repository; edit this file 'description' to name the repository.