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