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