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