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