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