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