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