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