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