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