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