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