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