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
was (Re: [PATCH] MakeMaker 5.55_03 -> 5.90_01)
[perl5.git] / perl.c
CommitLineData
a0d0e21e
LW		 1/* perl.c
2 *
be3c0a43 3 * Copyright (c) 1987-2002 Larry Wall
a687059c 4 *
352d5a3a
LW		 5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
a687059c 7 *
8d063cd8
LW		 8 */
9
a0d0e21e
LW		 10/*
11 * "A ship then new they built for him/of mithril and of elven glass" --Bilbo
12 */
45d8adaa 13
378cc40b 14#include "EXTERN.h"
864dbfa3 15#define PERL_IN_PERL_C
378cc40b 16#include "perl.h"
e3321bb0 17#include "patchlevel.h" /* for local_patches */
378cc40b 18
df5cef82 19/* XXX If this causes problems, set i_unistd=undef in the hint file. */
a0d0e21e
LW		 20#ifdef I_UNISTD
21#include <unistd.h>
22#endif
a0d0e21e 23
7114a2d2 24#if !defined(STANDARD_C) && !defined(HAS_GETENV_PROTOTYPE) && !defined(PERL_MICRO)
20ce7b12 25char *getenv (char *); /* Usually in <stdlib.h> */
54310121 26#endif
27
acfe0abc 28static I32 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen);
0cb96387 29
a687059c
LW		 30#ifdef IAMSUID
31#ifndef DOSUID
32#define DOSUID
33#endif
34#endif
378cc40b 35
a687059c
LW		 36#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
37#ifdef DOSUID
38#undef DOSUID
39#endif
40#endif
8d063cd8 41
4d1ff10f 42#if defined(USE_5005THREADS)
06d86050
GS		 43# define INIT_TLS_AND_INTERP \
44 STMT_START { \
45 if (!PL_curinterp) { \
46 PERL_SET_INTERP(my_perl); \
47 INIT_THREADS; \
48 ALLOC_THREAD_KEY; \
49 } \
50 } STMT_END
51#else
52# if defined(USE_ITHREADS)
53# define INIT_TLS_AND_INTERP \
54 STMT_START { \
55 if (!PL_curinterp) { \
56 PERL_SET_INTERP(my_perl); \
57 INIT_THREADS; \
58 ALLOC_THREAD_KEY; \
534825c4
GS		 59 PERL_SET_THX(my_perl); \
60 OP_REFCNT_INIT; \
61 } \
62 else { \
63 PERL_SET_THX(my_perl); \
06d86050 64 } \
06d86050
GS		 65 } STMT_END
66# else
67# define INIT_TLS_AND_INTERP \
68 STMT_START { \
69 if (!PL_curinterp) { \
70 PERL_SET_INTERP(my_perl); \
71 } \
72 PERL_SET_THX(my_perl); \
73 } STMT_END
74# endif
75#endif
76
32e30700
GS		 77#ifdef PERL_IMPLICIT_SYS
78PerlInterpreter *
7766f137
GS		 79perl_alloc_using(struct IPerlMem* ipM, struct IPerlMem* ipMS,
80 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
32e30700
GS		 81 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
82 struct IPerlDir* ipD, struct IPerlSock* ipS,
83 struct IPerlProc* ipP)
84{
85 PerlInterpreter *my_perl;
32e30700
GS		 86 /* New() needs interpreter, so call malloc() instead */
87 my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
06d86050 88 INIT_TLS_AND_INTERP;
32e30700
GS		 89 Zero(my_perl, 1, PerlInterpreter);
90 PL_Mem = ipM;
7766f137
GS		 91 PL_MemShared = ipMS;
92 PL_MemParse = ipMP;
32e30700
GS		 93 PL_Env = ipE;
94 PL_StdIO = ipStd;
95 PL_LIO = ipLIO;
96 PL_Dir = ipD;
97 PL_Sock = ipS;
98 PL_Proc = ipP;
7766f137 99
32e30700
GS		 100 return my_perl;
101}
102#else
954c1994
GS		 103
104/*
ccfc67b7
JH		 105=head1 Embedding Functions
106
954c1994
GS		 107=for apidoc perl_alloc
108
109Allocates a new Perl interpreter. See L<perlembed>.
110
111=cut
112*/
113
93a17b20 114PerlInterpreter *
cea2e8a9 115perl_alloc(void)
79072805 116{
cea2e8a9 117 PerlInterpreter *my_perl;
35d7cf2c
JH		 118#ifdef USE_5005THREADS
119 dTHX;
120#endif
79072805 121
54aff467 122 /* New() needs interpreter, so call malloc() instead */
e8ee3774 123 my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
ba869deb 124
06d86050 125 INIT_TLS_AND_INTERP;
dedcbb81 126 Zero(my_perl, 1, PerlInterpreter);
cea2e8a9 127 return my_perl;
79072805 128}
32e30700 129#endif /* PERL_IMPLICIT_SYS */
79072805 130
954c1994
GS		 131/*
132=for apidoc perl_construct
133
134Initializes a new Perl interpreter. See L<perlembed>.
135
136=cut
137*/
138
79072805 139void
0cb96387 140perl_construct(pTHXx)
79072805 141{
4d1ff10f 142#ifdef USE_5005THREADS
a863c7d1 143#ifndef FAKE_THREADS
e1f15930 144 struct perl_thread *thr = NULL;
a863c7d1 145#endif /* FAKE_THREADS */
4d1ff10f 146#endif /* USE_5005THREADS */
ba869deb 147
8990e307 148#ifdef MULTIPLICITY
54aff467 149 init_interp();
ac27b0f5 150 PL_perl_destruct_level = 1;
54aff467
GS		 151#else
152 if (PL_perl_destruct_level > 0)
153 init_interp();
154#endif
155
33f46ff6 156 /* Init the real globals (and main thread)? */
3280af22 157 if (!PL_linestr) {
4d1ff10f 158#ifdef USE_5005THREADS
533c011a 159 MUTEX_INIT(&PL_sv_mutex);
a863c7d1
MB		 160 /*
161 * Safe to use basic SV functions from now on (though
162 * not things like mortals or tainting yet).
163 */
533c011a
NIS		 164 MUTEX_INIT(&PL_eval_mutex);
165 COND_INIT(&PL_eval_cond);
166 MUTEX_INIT(&PL_threads_mutex);
167 COND_INIT(&PL_nthreads_cond);
ba869deb 168# ifdef EMULATE_ATOMIC_REFCOUNTS
533c011a 169 MUTEX_INIT(&PL_svref_mutex);
ba869deb 170# endif /* EMULATE_ATOMIC_REFCOUNTS */
a863c7d1 171
5ff3f7a4 172 MUTEX_INIT(&PL_cred_mutex);
3d35f11b
GS		 173 MUTEX_INIT(&PL_sv_lock_mutex);
174 MUTEX_INIT(&PL_fdpid_mutex);
5ff3f7a4 175
199100c8 176 thr = init_main_thread();
4d1ff10f 177#endif /* USE_5005THREADS */
11343788 178
14dd3ad8 179#ifdef PERL_FLEXIBLE_EXCEPTIONS
0b94c7bb 180 PL_protect = MEMBER_TO_FPTR(Perl_default_protect); /* for exceptions */
14dd3ad8 181#endif
312caa8e 182
2aea9f8a
GS		 183 PL_curcop = &PL_compiling; /* needed by ckWARN, right away */
184
3280af22
NIS		 185 PL_linestr = NEWSV(65,79);
186 sv_upgrade(PL_linestr,SVt_PVIV);
79072805 187
3280af22 188 if (!SvREADONLY(&PL_sv_undef)) {
d689ffdd
JP		 189 /* set read-only and try to insure than we wont see REFCNT==0
190 very often */
191
3280af22
NIS		 192 SvREADONLY_on(&PL_sv_undef);
193 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
79072805 194
3280af22
NIS		 195 sv_setpv(&PL_sv_no,PL_No);
196 SvNV(&PL_sv_no);
197 SvREADONLY_on(&PL_sv_no);
198 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
79072805 199
3280af22
NIS		 200 sv_setpv(&PL_sv_yes,PL_Yes);
201 SvNV(&PL_sv_yes);
202 SvREADONLY_on(&PL_sv_yes);
203 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
6e72f9df 204 }
79072805 205
cea2e8a9 206 PL_sighandlerp = Perl_sighandler;
3280af22 207 PL_pidstatus = newHV();
79072805
LW		 208 }
209
8bfdd7d9 210 PL_rs = newSVpvn("\n", 1);
dc92893f 211
cea2e8a9 212 init_stacks();
79072805 213
748a9306 214 init_ids();
3280af22 215 PL_lex_state = LEX_NOTPARSING;
a5f75d66 216
312caa8e 217 JMPENV_BOOTSTRAP;
f86702cc 218 STATUS_ALL_SUCCESS;
219
0672f40e 220 init_i18nl10n(1);
36477c24 221 SET_NUMERIC_STANDARD();
0b5b802d 222
a7cb1f99
GS		 223 {
224 U8 *s;
225 PL_patchlevel = NEWSV(0,4);
155aba94 226 (void)SvUPGRADE(PL_patchlevel, SVt_PVNV);
a7cb1f99 227 if (PERL_REVISION > 127 || PERL_VERSION > 127 || PERL_SUBVERSION > 127)
806e7201 228 SvGROW(PL_patchlevel, UTF8_MAXLEN*3+1);
a7cb1f99 229 s = (U8*)SvPVX(PL_patchlevel);
9041c2e3
NIS		 230 /* Build version strings using "native" characters */
231 s = uvchr_to_utf8(s, (UV)PERL_REVISION);
232 s = uvchr_to_utf8(s, (UV)PERL_VERSION);
233 s = uvchr_to_utf8(s, (UV)PERL_SUBVERSION);
a7cb1f99
GS		 234 *s = '\0';
235 SvCUR_set(PL_patchlevel, s - (U8*)SvPVX(PL_patchlevel));
236 SvPOK_on(PL_patchlevel);
237 SvNVX(PL_patchlevel) = (NV)PERL_REVISION
238 + ((NV)PERL_VERSION / (NV)1000)
cceca5ed 239#if defined(PERL_SUBVERSION) && PERL_SUBVERSION > 0
a7cb1f99 240 + ((NV)PERL_SUBVERSION / (NV)1000000)
a5f75d66 241#endif
a7cb1f99
GS		 242 ;
243 SvNOK_on(PL_patchlevel); /* dual valued */
244 SvUTF8_on(PL_patchlevel);
245 SvREADONLY_on(PL_patchlevel);
246 }
79072805 247
ab821d7f 248#if defined(LOCAL_PATCH_COUNT)
3280af22 249 PL_localpatches = local_patches; /* For possible -v */
ab821d7f 250#endif
251
52853b95
GS		 252#ifdef HAVE_INTERP_INTERN
253 sys_intern_init();
254#endif
255
3a1ee7e8 256 PerlIO_init(aTHX); /* Hook to IO system */
760ac839 257
3280af22
NIS		 258 PL_fdpid = newAV(); /* for remembering popen pids by fd */
259 PL_modglobal = newHV(); /* pointers to per-interpreter module globals */
24944567 260 PL_errors = newSVpvn("",0);
48c6b404 261 sv_setpvn(PERL_DEBUG_PAD(0), "", 0); /* For regex debugging. */
1f483ca1
JH		 262 sv_setpvn(PERL_DEBUG_PAD(1), "", 0); /* ext/re needs these */
263 sv_setpvn(PERL_DEBUG_PAD(2), "", 0); /* even without DEBUGGING. */
1fcf4c12 264#ifdef USE_ITHREADS
13137afc
AB		 265 PL_regex_padav = newAV();
266 av_push(PL_regex_padav,(SV*)newAV()); /* First entry is an array of empty elements */
267 PL_regex_pad = AvARRAY(PL_regex_padav);
1fcf4c12 268#endif
e5dd39fc 269#ifdef USE_REENTRANT_API
59bd0823 270 Perl_reentrant_init(aTHX);
e5dd39fc 271#endif
3d47000e
AB		 272
273 /* Note that strtab is a rather special HV. Assumptions are made
274 about not iterating on it, and not adding tie magic to it.
275 It is properly deallocated in perl_destruct() */
276 PL_strtab = newHV();
277
278#ifdef USE_5005THREADS
279 MUTEX_INIT(&PL_strtab_mutex);
280#endif
281 HvSHAREKEYS_off(PL_strtab); /* mandatory */
282 hv_ksplit(PL_strtab, 512);
283
0631ea03
AB		 284#if defined(__DYNAMIC__) && (defined(NeXT) || defined(__NeXT__))
285 _dyld_lookup_and_bind
286 ("__environ", (unsigned long *) &environ_pointer, NULL);
287#endif /* environ */
288
289#ifdef USE_ENVIRON_ARRAY
290 PL_origenviron = environ;
291#endif
292
8990e307 293 ENTER;
79072805
LW		 294}
295
954c1994 296/*
62375a60
NIS		 297=for apidoc nothreadhook
298
299Stub that provides thread hook for perl_destruct when there are
300no threads.
301
302=cut
303*/
304
305int
4e9e3734 306Perl_nothreadhook(pTHX)
62375a60
NIS		 307{
308 return 0;
309}
310
311/*
954c1994
GS		 312=for apidoc perl_destruct
313
314Shuts down a Perl interpreter. See L<perlembed>.
315
316=cut
317*/
318
31d77e54 319int
0cb96387 320perl_destruct(pTHXx)
79072805 321{
7c474504 322 volatile int destruct_level; /* 0=none, 1=full, 2=full with checks */
a0d0e21e 323 HV *hv;
4d1ff10f 324#ifdef USE_5005THREADS
33f46ff6 325 Thread t;
cea2e8a9 326 dTHX;
4d1ff10f 327#endif /* USE_5005THREADS */
8990e307 328
7766f137
GS		 329 /* wait for all pseudo-forked children to finish */
330 PERL_WAIT_FOR_CHILDREN;
331
4d1ff10f 332#ifdef USE_5005THREADS
0f15f207 333#ifndef FAKE_THREADS
8023c3ce
MB		 334 /* Pass 1 on any remaining threads: detach joinables, join zombies */
335 retry_cleanup:
533c011a 336 MUTEX_LOCK(&PL_threads_mutex);
bf49b057 337 DEBUG_S(PerlIO_printf(Perl_debug_log,
c7848ba1 338 "perl_destruct: waiting for %d threads...\n",
533c011a 339 PL_nthreads - 1));
33f46ff6 340 for (t = thr->next; t != thr; t = t->next) {
605e5515
MB		 341 MUTEX_LOCK(&t->mutex);
342 switch (ThrSTATE(t)) {
343 AV *av;
c7848ba1 344 case THRf_ZOMBIE:
bf49b057 345 DEBUG_S(PerlIO_printf(Perl_debug_log,
c7848ba1 346 "perl_destruct: joining zombie %p\n", t));
605e5515
MB		 347 ThrSETSTATE(t, THRf_DEAD);
348 MUTEX_UNLOCK(&t->mutex);
533c011a 349 PL_nthreads--;
8023c3ce
MB		 350 /*
351 * The SvREFCNT_dec below may take a long time (e.g. av
352 * may contain an object scalar whose destructor gets
353 * called) so we have to unlock threads_mutex and start
354 * all over again.
355 */
533c011a 356 MUTEX_UNLOCK(&PL_threads_mutex);
ea0efc06 357 JOIN(t, &av);
605e5515 358 SvREFCNT_dec((SV*)av);
bf49b057 359 DEBUG_S(PerlIO_printf(Perl_debug_log,
c7848ba1 360 "perl_destruct: joined zombie %p OK\n", t));
8023c3ce 361 goto retry_cleanup;
c7848ba1 362 case THRf_R_JOINABLE:
bf49b057 363 DEBUG_S(PerlIO_printf(Perl_debug_log,
c7848ba1
MB		 364 "perl_destruct: detaching thread %p\n", t));
365 ThrSETSTATE(t, THRf_R_DETACHED);
ac27b0f5 366 /*
c7848ba1
MB		 367 * We unlock threads_mutex and t->mutex in the opposite order
368 * from which we locked them just so that DETACH won't
369 * deadlock if it panics. It's only a breach of good style
370 * not a bug since they are unlocks not locks.
371 */
533c011a 372 MUTEX_UNLOCK(&PL_threads_mutex);
c7848ba1
MB		 373 DETACH(t);
374 MUTEX_UNLOCK(&t->mutex);
8023c3ce 375 goto retry_cleanup;
c7848ba1 376 default:
bf49b057 377 DEBUG_S(PerlIO_printf(Perl_debug_log,
c7848ba1
MB		 378 "perl_destruct: ignoring %p (state %u)\n",
379 t, ThrSTATE(t)));
380 MUTEX_UNLOCK(&t->mutex);
c7848ba1 381 /* fall through and out */
33f46ff6
MB		 382 }
383 }
8023c3ce
MB		 384 /* We leave the above "Pass 1" loop with threads_mutex still locked */
385
386 /* Pass 2 on remaining threads: wait for the thread count to drop to one */
533c011a 387 while (PL_nthreads > 1)
11343788 388 {
bf49b057 389 DEBUG_S(PerlIO_printf(Perl_debug_log,
c7848ba1 390 "perl_destruct: final wait for %d threads\n",
533c011a
NIS		 391 PL_nthreads - 1));
392 COND_WAIT(&PL_nthreads_cond, &PL_threads_mutex);
11343788
MB		 393 }
394 /* At this point, we're the last thread */
533c011a 395 MUTEX_UNLOCK(&PL_threads_mutex);
bf49b057 396 DEBUG_S(PerlIO_printf(Perl_debug_log, "perl_destruct: armageddon has arrived\n"));
533c011a
NIS		 397 MUTEX_DESTROY(&PL_threads_mutex);
398 COND_DESTROY(&PL_nthreads_cond);
b57a092c 399 PL_nthreads--;
0f15f207 400#endif /* !defined(FAKE_THREADS) */
4d1ff10f 401#endif /* USE_5005THREADS */
11343788 402
3280af22 403 destruct_level = PL_perl_destruct_level;
4633a7c4
LW		 404#ifdef DEBUGGING
405 {
406 char *s;
155aba94 407 if ((s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL"))) {
5f05dabc 408 int i = atoi(s);
409 if (destruct_level < i)
410 destruct_level = i;
411 }
4633a7c4
LW		 412 }
413#endif
414
31d77e54
AB		 415
416 if(PL_exit_flags & PERL_EXIT_DESTRUCT_END) {
f3faeb53
AB		 417 dJMPENV;
418 int x = 0;
419
420 JMPENV_PUSH(x);
421 if (PL_endav && !PL_minus_c)
422 call_list(PL_scopestack_ix, PL_endav);
423 JMPENV_POP;
26f423df 424 }
f3faeb53 425 LEAVE;
a0d0e21e
LW		 426 FREETMPS;
427
62375a60
NIS		 428 if (CALL_FPTR(PL_threadhook)(aTHX)) {
429 /* Threads hook has vetoed further cleanup */
430 return STATUS_NATIVE_EXPORT;;
431 }
432
ff0cee69 433 /* We must account for everything. */
434
435 /* Destroy the main CV and syntax tree */
3280af22
NIS		 436 if (PL_main_root) {
437 PL_curpad = AvARRAY(PL_comppad);
438 op_free(PL_main_root);
439 PL_main_root = Nullop;
a0d0e21e 440 }
3280af22
NIS		 441 PL_curcop = &PL_compiling;
442 PL_main_start = Nullop;
443 SvREFCNT_dec(PL_main_cv);
444 PL_main_cv = Nullcv;
24d3c518 445 PL_dirty = TRUE;
ff0cee69 446
13621cfb
NIS		 447 /* Tell PerlIO we are about to tear things apart in case
448 we have layers which are using resources that should
449 be cleaned up now.
450 */
451
452 PerlIO_destruct(aTHX);
453
3280af22 454 if (PL_sv_objcount) {
a0d0e21e
LW		 455 /*
456 * Try to destruct global references. We do this first so that the
457 * destructors and destructees still exist. Some sv's might remain.
458 * Non-referenced objects are on their own.
459 */
a0d0e21e 460 sv_clean_objs();
8990e307
LW		 461 }
462
5cd24f17 463 /* unhook hooks which will soon be, or use, destroyed data */
3280af22
NIS		 464 SvREFCNT_dec(PL_warnhook);
465 PL_warnhook = Nullsv;
466 SvREFCNT_dec(PL_diehook);
467 PL_diehook = Nullsv;
5cd24f17 468
4b556e6c 469 /* call exit list functions */
3280af22 470 while (PL_exitlistlen-- > 0)
acfe0abc 471 PL_exitlist[PL_exitlistlen].fn(aTHX_ PL_exitlist[PL_exitlistlen].ptr);
4b556e6c 472
3280af22 473 Safefree(PL_exitlist);
4b556e6c 474
a0d0e21e 475 if (destruct_level == 0){
8990e307 476
a0d0e21e 477 DEBUG_P(debprofdump());
ac27b0f5 478
56a2bab7
NIS		 479#if defined(PERLIO_LAYERS)
480 /* No more IO - including error messages ! */
481 PerlIO_cleanup(aTHX);
482#endif
483
a0d0e21e 484 /* The exit() function will do everything that needs doing. */
31d77e54 485 return STATUS_NATIVE_EXPORT;;
a0d0e21e 486 }
5dd60ef7 487
551a8b83 488 /* jettison our possibly duplicated environment */
4b647fb0
DM		 489 /* if PERL_USE_SAFE_PUTENV is defined environ will not have been copied
490 * so we certainly shouldn't free it here
491 */
492#if defined(USE_ENVIRON_ARRAY) && !defined(PERL_USE_SAFE_PUTENV)
551a8b83
JH		 493 if (environ != PL_origenviron) {
494 I32 i;
495
496 for (i = 0; environ[i]; i++)
4b420006 497 safesysfree(environ[i]);
0631ea03 498
4b420006
JH		 499 /* Must use safesysfree() when working with environ. */
500 safesysfree(environ);
551a8b83
JH		 501
502 environ = PL_origenviron;
503 }
504#endif
505
5f8cb046
DM		 506#ifdef USE_ITHREADS
507 /* the syntax tree is shared between clones
508 * so op_free(PL_main_root) only ReREFCNT_dec's
509 * REGEXPs in the parent interpreter
510 * we need to manually ReREFCNT_dec for the clones
511 */
512 {
513 I32 i = AvFILLp(PL_regex_padav) + 1;
514 SV **ary = AvARRAY(PL_regex_padav);
515
516 while (i) {
35061a7e 517 SV *resv = ary[--i];
ba89bb6e 518 REGEXP *re = INT2PTR(REGEXP *,SvIVX(resv));
35061a7e
DM		 519
520 if (SvFLAGS(resv) & SVf_BREAK) {
577e12cc 521 /* this is PL_reg_curpm, already freed
35061a7e
DM		 522 * flag is set in regexec.c:S_regtry
523 */
524 SvFLAGS(resv) &= ~SVf_BREAK;
3a1ee7e8 525 }
1cc8b4c5
AB		 526 else if(SvREPADTMP(resv)) {
527 SvREPADTMP_off(resv);
528 }
35061a7e 529 else {
5f8cb046
DM		 530 ReREFCNT_dec(re);
531 }
532 }
533 }
534 SvREFCNT_dec(PL_regex_padav);
535 PL_regex_padav = Nullav;
536 PL_regex_pad = NULL;
537#endif
538
5f05dabc 539 /* loosen bonds of global variables */
540
3280af22
NIS		 541 if(PL_rsfp) {
542 (void)PerlIO_close(PL_rsfp);
543 PL_rsfp = Nullfp;
8ebc5c01 544 }
545
546 /* Filters for program text */
3280af22
NIS		 547 SvREFCNT_dec(PL_rsfp_filters);
548 PL_rsfp_filters = Nullav;
8ebc5c01 549
550 /* switches */
3280af22
NIS		 551 PL_preprocess = FALSE;
552 PL_minus_n = FALSE;
553 PL_minus_p = FALSE;
554 PL_minus_l = FALSE;
555 PL_minus_a = FALSE;
556 PL_minus_F = FALSE;
557 PL_doswitches = FALSE;
599cee73 558 PL_dowarn = G_WARN_OFF;
3280af22
NIS		 559 PL_doextract = FALSE;
560 PL_sawampersand = FALSE; /* must save all match strings */
3280af22
NIS		 561 PL_unsafe = FALSE;
562
563 Safefree(PL_inplace);
564 PL_inplace = Nullch;
a7cb1f99 565 SvREFCNT_dec(PL_patchlevel);
3280af22
NIS		 566
567 if (PL_e_script) {
568 SvREFCNT_dec(PL_e_script);
569 PL_e_script = Nullsv;
8ebc5c01 570 }
571
bc0a45ed
DM		 572 while (--PL_origargc >= 0) {
573 Safefree(PL_origargv[PL_origargc]);
574 }
575 Safefree(PL_origargv);
576
8ebc5c01 577 /* magical thingies */
578
7889fe52
NIS		 579 SvREFCNT_dec(PL_ofs_sv); /* $, */
580 PL_ofs_sv = Nullsv;
5f05dabc 581
7889fe52
NIS		 582 SvREFCNT_dec(PL_ors_sv); /* $\ */
583 PL_ors_sv = Nullsv;
8ebc5c01 584
3280af22
NIS		 585 SvREFCNT_dec(PL_rs); /* $/ */
586 PL_rs = Nullsv;
dc92893f 587
d33b2eba
GS		 588 PL_multiline = 0; /* $* */
589 Safefree(PL_osname); /* $^O */
590 PL_osname = Nullch;
5f05dabc 591
3280af22
NIS		 592 SvREFCNT_dec(PL_statname);
593 PL_statname = Nullsv;
594 PL_statgv = Nullgv;
5f05dabc 595
8ebc5c01 596 /* defgv, aka *_ should be taken care of elsewhere */
597
8ebc5c01 598 /* clean up after study() */
3280af22
NIS		 599 SvREFCNT_dec(PL_lastscream);
600 PL_lastscream = Nullsv;
601 Safefree(PL_screamfirst);
602 PL_screamfirst = 0;
603 Safefree(PL_screamnext);
604 PL_screamnext = 0;
8ebc5c01 605
7d5ea4e7
GS		 606 /* float buffer */
607 Safefree(PL_efloatbuf);
608 PL_efloatbuf = Nullch;
609 PL_efloatsize = 0;
610
8ebc5c01 611 /* startup and shutdown function lists */
3280af22 612 SvREFCNT_dec(PL_beginav);
5a837c8f 613 SvREFCNT_dec(PL_beginav_save);
3280af22 614 SvREFCNT_dec(PL_endav);
7d30b5c4 615 SvREFCNT_dec(PL_checkav);
3280af22
NIS		 616 SvREFCNT_dec(PL_initav);
617 PL_beginav = Nullav;
5a837c8f 618 PL_beginav_save = Nullav;
3280af22 619 PL_endav = Nullav;
7d30b5c4 620 PL_checkav = Nullav;
3280af22 621 PL_initav = Nullav;
5618dfe8 622
8ebc5c01 623 /* shortcuts just get cleared */
3280af22 624 PL_envgv = Nullgv;
3280af22
NIS		 625 PL_incgv = Nullgv;
626 PL_hintgv = Nullgv;
627 PL_errgv = Nullgv;
628 PL_argvgv = Nullgv;
629 PL_argvoutgv = Nullgv;
630 PL_stdingv = Nullgv;
bf49b057 631 PL_stderrgv = Nullgv;
3280af22
NIS		 632 PL_last_in_gv = Nullgv;
633 PL_replgv = Nullgv;
5c831c24 634 PL_debstash = Nullhv;
8ebc5c01 635
636 /* reset so print() ends up where we expect */
637 setdefout(Nullgv);
5c831c24 638
7a1c5554
GS		 639 SvREFCNT_dec(PL_argvout_stack);
640 PL_argvout_stack = Nullav;
8ebc5c01 641
5c831c24
GS		 642 SvREFCNT_dec(PL_modglobal);
643 PL_modglobal = Nullhv;
644 SvREFCNT_dec(PL_preambleav);
645 PL_preambleav = Nullav;
646 SvREFCNT_dec(PL_subname);
647 PL_subname = Nullsv;
648 SvREFCNT_dec(PL_linestr);
649 PL_linestr = Nullsv;
650 SvREFCNT_dec(PL_pidstatus);
651 PL_pidstatus = Nullhv;
652 SvREFCNT_dec(PL_toptarget);
653 PL_toptarget = Nullsv;
654 SvREFCNT_dec(PL_bodytarget);
655 PL_bodytarget = Nullsv;
656 PL_formtarget = Nullsv;
657
d33b2eba 658 /* free locale stuff */
b9582b6a 659#ifdef USE_LOCALE_COLLATE
d33b2eba
GS		 660 Safefree(PL_collation_name);
661 PL_collation_name = Nullch;
b9582b6a 662#endif
d33b2eba 663
b9582b6a 664#ifdef USE_LOCALE_NUMERIC
d33b2eba
GS		 665 Safefree(PL_numeric_name);
666 PL_numeric_name = Nullch;
a453c169 667 SvREFCNT_dec(PL_numeric_radix_sv);
b9582b6a 668#endif
d33b2eba 669
5c831c24
GS		 670 /* clear utf8 character classes */
671 SvREFCNT_dec(PL_utf8_alnum);
672 SvREFCNT_dec(PL_utf8_alnumc);
673 SvREFCNT_dec(PL_utf8_ascii);
674 SvREFCNT_dec(PL_utf8_alpha);
675 SvREFCNT_dec(PL_utf8_space);
676 SvREFCNT_dec(PL_utf8_cntrl);
677 SvREFCNT_dec(PL_utf8_graph);
678 SvREFCNT_dec(PL_utf8_digit);
679 SvREFCNT_dec(PL_utf8_upper);
680 SvREFCNT_dec(PL_utf8_lower);
681 SvREFCNT_dec(PL_utf8_print);
682 SvREFCNT_dec(PL_utf8_punct);
683 SvREFCNT_dec(PL_utf8_xdigit);
684 SvREFCNT_dec(PL_utf8_mark);
685 SvREFCNT_dec(PL_utf8_toupper);
4dbdbdc2 686 SvREFCNT_dec(PL_utf8_totitle);
5c831c24 687 SvREFCNT_dec(PL_utf8_tolower);
b4e400f9 688 SvREFCNT_dec(PL_utf8_tofold);
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
3280af22 2689 PL_curstash = PL_defstash = newHV();
79cb57f6 2690 PL_curstname = newSVpvn("main",4);
adbc6bb1
LW		 2691 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
2692 SvREFCNT_dec(GvHV(gv));
3280af22 2693 GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);
463ee0b2 2694 SvREADONLY_on(gv);
3280af22
NIS		 2695 HvNAME(PL_defstash) = savepv("main");
2696 PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
2697 GvMULTI_on(PL_incgv);
2698 PL_hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */
2699 GvMULTI_on(PL_hintgv);
2700 PL_defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
2701 PL_errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
2702 GvMULTI_on(PL_errgv);
2703 PL_replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */
2704 GvMULTI_on(PL_replgv);
cea2e8a9 2705 (void)Perl_form(aTHX_ "%240s",""); /* Preallocate temp - for immediate signals. */
38a03e6e
MB		 2706 sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
2707 sv_setpvn(ERRSV, "", 0);
3280af22 2708 PL_curstash = PL_defstash;
11faa288 2709 CopSTASH_set(&PL_compiling, PL_defstash);
ed094faf 2710 PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
3280af22 2711 PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
92d29cee 2712 PL_nullstash = GvHV(gv_fetchpv("<none>::", GV_ADDMULTI, SVt_PVHV));
4633a7c4 2713 /* We must init $/ before switches are processed. */
864dbfa3 2714 sv_setpvn(get_sv("/", TRUE), "\n", 1);
79072805
LW		 2715}
2716
76e3520e 2717STATIC void
cea2e8a9 2718S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript)
79072805 2719{
1b24ed4b
MS		 2720 char *quote;
2721 char *code;
2722 char *cpp_discard_flag;
2723 char *perl;
2724
6c4ab083 2725 *fdscript = -1;
79072805 2726
3280af22
NIS		 2727 if (PL_e_script) {
2728 PL_origfilename = savepv("-e");
96436eeb 2729 }
6c4ab083
GS		 2730 else {
2731 /* if find_script() returns, it returns a malloc()-ed value */
3280af22 2732 PL_origfilename = scriptname = find_script(scriptname, dosearch, NULL, 1);
6c4ab083
GS		 2733
2734 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
2735 char *s = scriptname + 8;
2736 *fdscript = atoi(s);
2737 while (isDIGIT(*s))
2738 s++;
2739 if (*s) {
2740 scriptname = savepv(s + 1);
3280af22
NIS		 2741 Safefree(PL_origfilename);
2742 PL_origfilename = scriptname;
6c4ab083
GS		 2743 }
2744 }
2745 }
2746
05ec9bb3 2747 CopFILE_free(PL_curcop);
57843af0 2748 CopFILE_set(PL_curcop, PL_origfilename);
3280af22 2749 if (strEQ(PL_origfilename,"-"))
79072805 2750 scriptname = "";
01f988be 2751 if (*fdscript >= 0) {
3280af22 2752 PL_rsfp = PerlIO_fdopen(*fdscript,PERL_SCRIPT_MODE);
1b24ed4b
MS		 2753# if defined(HAS_FCNTL) && defined(F_SETFD)
2754 if (PL_rsfp)
2755 /* ensure close-on-exec */
2756 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);
2757# endif
96436eeb 2758 }
3280af22 2759 else if (PL_preprocess) {
46fc3d4c 2760 char *cpp_cfg = CPPSTDIN;
79cb57f6 2761 SV *cpp = newSVpvn("",0);
46fc3d4c 2762 SV *cmd = NEWSV(0,0);
2763
2764 if (strEQ(cpp_cfg, "cppstdin"))
cea2e8a9 2765 Perl_sv_catpvf(aTHX_ cpp, "%s/", BIN_EXP);
46fc3d4c 2766 sv_catpv(cpp, cpp_cfg);
79072805 2767
1b24ed4b
MS		 2768# ifndef VMS
2769 sv_catpvn(sv, "-I", 2);
2770 sv_catpv(sv,PRIVLIB_EXP);
2771# endif
46fc3d4c 2772
14953ddc
MB		 2773 DEBUG_P(PerlIO_printf(Perl_debug_log,
2774 "PL_preprocess: scriptname=\"%s\", cpp=\"%s\", sv=\"%s\", CPPMINUS=\"%s\"\n",
2775 scriptname, SvPVX (cpp), SvPVX (sv), CPPMINUS));
1b24ed4b
MS		 2776
2777# if defined(MSDOS) || defined(WIN32) || defined(VMS)
2778 quote = "\"";
2779# else
2780 quote = "'";
2781# endif
2782
2783# ifdef VMS
2784 cpp_discard_flag = "";
2785# else
2786 cpp_discard_flag = "-C";
2787# endif
2788
2789# ifdef OS2
2790 perl = os2_execname(aTHX);
2791# else
2792 perl = PL_origargv[0];
2793# endif
2794
2795
2796 /* This strips off Perl comments which might interfere with
62375a60
NIS		 2797 the C pre-processor, including #!. #line directives are
2798 deliberately stripped to avoid confusion with Perl's version
1b24ed4b
MS		 2799 of #line. FWP played some golf with it so it will fit
2800 into VMS's 255 character buffer.
2801 */
2802 if( PL_doextract )
2803 code = "(1../^#!.*perl/i)|/^\\s*#(?!\\s*((ifn?|un)def|(el|end)?if|define|include|else|error|pragma)\\b)/||!($|=1)||print";
2804 else
2805 code = "/^\\s*#(?!\\s*((ifn?|un)def|(el|end)?if|define|include|else|error|pragma)\\b)/||!($|=1)||print";
2806
2807 Perl_sv_setpvf(aTHX_ cmd, "\
2808%s -ne%s%s%s %s | %"SVf" %s %"SVf" %s",
62375a60 2809 perl, quote, code, quote, scriptname, cpp,
1b24ed4b
MS		 2810 cpp_discard_flag, sv, CPPMINUS);
2811
3280af22 2812 PL_doextract = FALSE;
1b24ed4b
MS		 2813# ifdef IAMSUID /* actually, this is caught earlier */
2814 if (PL_euid != PL_uid && !PL_euid) { /* if running suidperl */
2815# ifdef HAS_SETEUID
2816 (void)seteuid(PL_uid); /* musn't stay setuid root */
2817# else
2818# ifdef HAS_SETREUID
2819 (void)setreuid((Uid_t)-1, PL_uid);
2820# else
2821# ifdef HAS_SETRESUID
2822 (void)setresuid((Uid_t)-1, PL_uid, (Uid_t)-1);
2823# else
2824 PerlProc_setuid(PL_uid);
2825# endif
2826# endif
2827# endif
b28d0864 2828 if (PerlProc_geteuid() != PL_uid)
cea2e8a9 2829 Perl_croak(aTHX_ "Can't do seteuid!\n");
79072805 2830 }
1b24ed4b 2831# endif /* IAMSUID */
0a6c758d 2832
62375a60
NIS		 2833 DEBUG_P(PerlIO_printf(Perl_debug_log,
2834 "PL_preprocess: cmd=\"%s\"\n",
0a6c758d
MS		 2835 SvPVX(cmd)));
2836
3280af22 2837 PL_rsfp = PerlProc_popen(SvPVX(cmd), "r");
46fc3d4c 2838 SvREFCNT_dec(cmd);
2839 SvREFCNT_dec(cpp);
79072805
LW		 2840 }
2841 else if (!*scriptname) {
bbce6d69 2842 forbid_setid("program input from stdin");
3280af22 2843 PL_rsfp = PerlIO_stdin();
79072805 2844 }
96436eeb 2845 else {
3280af22 2846 PL_rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
1b24ed4b
MS		 2847# if defined(HAS_FCNTL) && defined(F_SETFD)
2848 if (PL_rsfp)
2849 /* ensure close-on-exec */
2850 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);
2851# endif
96436eeb 2852 }
3280af22 2853 if (!PL_rsfp) {
1b24ed4b
MS		 2854# ifdef DOSUID
2855# ifndef IAMSUID /* in case script is not readable before setuid */
2856 if (PL_euid &&
2857 PerlLIO_stat(CopFILE(PL_curcop),&PL_statbuf) >= 0 &&
2858 PL_statbuf.st_mode & (S_ISUID|S_ISGID))
2859 {
2860 /* try again */
62375a60
NIS		 2861 PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT,
2862 BIN_EXP, (int)PERL_REVISION,
1b24ed4b
MS		 2863 (int)PERL_VERSION,
2864 (int)PERL_SUBVERSION), PL_origargv);
2865 Perl_croak(aTHX_ "Can't do setuid\n");
2866 }
2867# endif
2868# endif
2869# ifdef IAMSUID
2870 errno = EPERM;
2871 Perl_croak(aTHX_ "Can't open perl script: %s\n",
2872 Strerror(errno));
2873# else
2874 Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
2875 CopFILE(PL_curcop), Strerror(errno));
2876# endif
13281fa4 2877 }
79072805 2878}
8d063cd8 2879
7b89560d
JH		 2880/* Mention
2881 * I_SYSSTATVFS HAS_FSTATVFS
2882 * I_SYSMOUNT
c890dc6c 2883 * I_STATFS HAS_FSTATFS HAS_GETFSSTAT
7b89560d
JH		 2884 * I_MNTENT HAS_GETMNTENT HAS_HASMNTOPT
2885 * here so that metaconfig picks them up. */
2886
104d25b7 2887#ifdef IAMSUID
864dbfa3 2888STATIC int
e688b231 2889S_fd_on_nosuid_fs(pTHX_ int fd)
104d25b7 2890{
0545a864
JH		 2891 int check_okay = 0; /* able to do all the required sys/libcalls */
2892 int on_nosuid = 0; /* the fd is on a nosuid fs */
104d25b7 2893/*
ad27e871 2894 * Preferred order: fstatvfs(), fstatfs(), ustat()+getmnt(), getmntent().
e688b231 2895 * fstatvfs() is UNIX98.
0545a864 2896 * fstatfs() is 4.3 BSD.
ad27e871 2897 * ustat()+getmnt() is pre-4.3 BSD.
0545a864
JH		 2898 * getmntent() is O(number-of-mounted-filesystems) and can hang on
2899 * an irrelevant filesystem while trying to reach the right one.
104d25b7
JH		 2900 */
2901
6439433f
JH		 2902#undef FD_ON_NOSUID_CHECK_OKAY /* found the syscalls to do the check? */
2903
2904# if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
2905 defined(HAS_FSTATVFS)
2906# define FD_ON_NOSUID_CHECK_OKAY
104d25b7 2907 struct statvfs stfs;
6439433f 2908
104d25b7
JH		 2909 check_okay = fstatvfs(fd, &stfs) == 0;
2910 on_nosuid = check_okay && (stfs.f_flag & ST_NOSUID);
6439433f 2911# endif /* fstatvfs */
ac27b0f5 2912
6439433f
JH		 2913# if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
2914 defined(PERL_MOUNT_NOSUID) && \
2915 defined(HAS_FSTATFS) && \
2916 defined(HAS_STRUCT_STATFS) && \
2917 defined(HAS_STRUCT_STATFS_F_FLAGS)
2918# define FD_ON_NOSUID_CHECK_OKAY
e688b231 2919 struct statfs stfs;
6439433f 2920
104d25b7 2921 check_okay = fstatfs(fd, &stfs) == 0;
104d25b7 2922 on_nosuid = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID);
6439433f
JH		 2923# endif /* fstatfs */
2924
2925# if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
2926 defined(PERL_MOUNT_NOSUID) && \
2927 defined(HAS_FSTAT) && \
2928 defined(HAS_USTAT) && \
2929 defined(HAS_GETMNT) && \
2930 defined(HAS_STRUCT_FS_DATA) && \
2931 defined(NOSTAT_ONE)
2932# define FD_ON_NOSUID_CHECK_OKAY
0545a864 2933 struct stat fdst;
6439433f 2934
0545a864 2935 if (fstat(fd, &fdst) == 0) {
6439433f
JH		 2936 struct ustat us;
2937 if (ustat(fdst.st_dev, &us) == 0) {
2938 struct fs_data fsd;
2939 /* NOSTAT_ONE here because we're not examining fields which
2940 * vary between that case and STAT_ONE. */
ad27e871 2941 if (getmnt((int*)0, &fsd, (int)0, NOSTAT_ONE, us.f_fname) == 0) {
6439433f
JH		 2942 size_t cmplen = sizeof(us.f_fname);
2943 if (sizeof(fsd.fd_req.path) < cmplen)
2944 cmplen = sizeof(fsd.fd_req.path);
2945 if (strnEQ(fsd.fd_req.path, us.f_fname, cmplen) &&
2946 fdst.st_dev == fsd.fd_req.dev) {
2947 check_okay = 1;
2948 on_nosuid = fsd.fd_req.flags & PERL_MOUNT_NOSUID;
2949 }
2950 }
2951 }
2952 }
0545a864 2953 }
6439433f
JH		 2954# endif /* fstat+ustat+getmnt */
2955
2956# if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
2957 defined(HAS_GETMNTENT) && \
2958 defined(HAS_HASMNTOPT) && \
2959 defined(MNTOPT_NOSUID)
2960# define FD_ON_NOSUID_CHECK_OKAY
2961 FILE *mtab = fopen("/etc/mtab", "r");
2962 struct mntent *entry;
2963 struct stat stb, fsb;
104d25b7
JH		 2964
2965 if (mtab && (fstat(fd, &stb) == 0)) {
6439433f
JH		 2966 while (entry = getmntent(mtab)) {
2967 if (stat(entry->mnt_dir, &fsb) == 0
2968 && fsb.st_dev == stb.st_dev)
2969 {
2970 /* found the filesystem */
2971 check_okay = 1;
2972 if (hasmntopt(entry, MNTOPT_NOSUID))
2973 on_nosuid = 1;
2974 break;
2975 } /* A single fs may well fail its stat(). */
2976 }
104d25b7
JH		 2977 }
2978 if (mtab)
6439433f
JH		 2979 fclose(mtab);
2980# endif /* getmntent+hasmntopt */
0545a864 2981
ac27b0f5 2982 if (!check_okay)
0545a864 2983 Perl_croak(aTHX_ "Can't check filesystem of script \"%s\" for nosuid", PL_origfilename);
104d25b7
JH		 2984 return on_nosuid;
2985}
2986#endif /* IAMSUID */
2987
76e3520e 2988STATIC void
cea2e8a9 2989S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript)
79072805 2990{
155aba94 2991#ifdef IAMSUID
96436eeb 2992 int which;
155aba94 2993#endif
96436eeb 2994
13281fa4
LW		 2995 /* do we need to emulate setuid on scripts? */
2996
2997 /* This code is for those BSD systems that have setuid #! scripts disabled
2998 * in the kernel because of a security problem. Merely defining DOSUID
2999 * in perl will not fix that problem, but if you have disabled setuid
3000 * scripts in the kernel, this will attempt to emulate setuid and setgid
3001 * on scripts that have those now-otherwise-useless bits set. The setuid
27e2fb84
LW		 3002 * root version must be called suidperl or sperlN.NNN. If regular perl
3003 * discovers that it has opened a setuid script, it calls suidperl with
3004 * the same argv that it had. If suidperl finds that the script it has
3005 * just opened is NOT setuid root, it sets the effective uid back to the
3006 * uid. We don't just make perl setuid root because that loses the
3007 * effective uid we had before invoking perl, if it was different from the
3008 * uid.
13281fa4
LW		 3009 *
3010 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
3011 * be defined in suidperl only. suidperl must be setuid root. The
3012 * Configure script will set this up for you if you want it.
3013 */
a687059c 3014
13281fa4 3015#ifdef DOSUID
6e72f9df 3016 char *s, *s2;
a0d0e21e 3017
b28d0864 3018 if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0) /* normal stat is insecure */
cea2e8a9 3019 Perl_croak(aTHX_ "Can't stat script \"%s\"",PL_origfilename);
b28d0864 3020 if (fdscript < 0 && PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
79072805 3021 I32 len;
2d8e6c8d 3022 STRLEN n_a;
13281fa4 3023
a687059c 3024#ifdef IAMSUID
fe14fcc3 3025#ifndef HAS_SETREUID
a687059c
LW		 3026 /* On this access check to make sure the directories are readable,
3027 * there is actually a small window that the user could use to make
3028 * filename point to an accessible directory. So there is a faint
3029 * chance that someone could execute a setuid script down in a
3030 * non-accessible directory. I don't know what to do about that.
3031 * But I don't think it's too important. The manual lies when
3032 * it says access() is useful in setuid programs.
3033 */
cc49e20b 3034 if (PerlLIO_access(CopFILE(PL_curcop),1)) /*double check*/
cea2e8a9 3035 Perl_croak(aTHX_ "Permission denied");
a687059c
LW		 3036#else
3037 /* If we can swap euid and uid, then we can determine access rights
3038 * with a simple stat of the file, and then compare device and
3039 * inode to make sure we did stat() on the same file we opened.
3040 * Then we just have to make sure he or she can execute it.
3041 */
3042 {
3043 struct stat tmpstatbuf;
3044
85e6fe83
LW		 3045 if (
3046#ifdef HAS_SETREUID
b28d0864 3047 setreuid(PL_euid,PL_uid) < 0
a0d0e21e
LW		 3048#else
3049# if HAS_SETRESUID
b28d0864 3050 setresuid(PL_euid,PL_uid,(Uid_t)-1) < 0
a0d0e21e 3051# endif
85e6fe83 3052#endif
b28d0864 3053 || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
cea2e8a9 3054 Perl_croak(aTHX_ "Can't swap uid and euid"); /* really paranoid */
cc49e20b 3055 if (PerlLIO_stat(CopFILE(PL_curcop),&tmpstatbuf) < 0)
cea2e8a9 3056 Perl_croak(aTHX_ "Permission denied"); /* testing full pathname here */
2bb3463c 3057#if defined(IAMSUID) && !defined(NO_NOSUID_CHECK)
e688b231 3058 if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp)))
cea2e8a9 3059 Perl_croak(aTHX_ "Permission denied");
104d25b7 3060#endif
b28d0864
NIS		 3061 if (tmpstatbuf.st_dev != PL_statbuf.st_dev ||
3062 tmpstatbuf.st_ino != PL_statbuf.st_ino) {
3063 (void)PerlIO_close(PL_rsfp);
cea2e8a9 3064 Perl_croak(aTHX_ "Permission denied\n");
a687059c 3065 }
85e6fe83
LW		 3066 if (
3067#ifdef HAS_SETREUID
b28d0864 3068 setreuid(PL_uid,PL_euid) < 0
a0d0e21e
LW		 3069#else
3070# if defined(HAS_SETRESUID)
b28d0864 3071 setresuid(PL_uid,PL_euid,(Uid_t)-1) < 0
a0d0e21e 3072# endif
85e6fe83 3073#endif
b28d0864 3074 || PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid)
cea2e8a9 3075 Perl_croak(aTHX_ "Can't reswap uid and euid");
b28d0864 3076 if (!cando(S_IXUSR,FALSE,&PL_statbuf)) /* can real uid exec? */
cea2e8a9 3077 Perl_croak(aTHX_ "Permission denied\n");
a687059c 3078 }
fe14fcc3 3079#endif /* HAS_SETREUID */
a687059c
LW		 3080#endif /* IAMSUID */
3081
b28d0864 3082 if (!S_ISREG(PL_statbuf.st_mode))
cea2e8a9 3083 Perl_croak(aTHX_ "Permission denied");
b28d0864 3084 if (PL_statbuf.st_mode & S_IWOTH)
cea2e8a9 3085 Perl_croak(aTHX_ "Setuid/gid script is writable by world");
6b88bc9c 3086 PL_doswitches = FALSE; /* -s is insecure in suid */
57843af0 3087 CopLINE_inc(PL_curcop);
6b88bc9c 3088 if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch ||
2d8e6c8d 3089 strnNE(SvPV(PL_linestr,n_a),"#!",2) ) /* required even on Sys V */
cea2e8a9 3090 Perl_croak(aTHX_ "No #! line");
2d8e6c8d 3091 s = SvPV(PL_linestr,n_a)+2;
663a0e37 3092 if (*s == ' ') s++;
45d8adaa 3093 while (!isSPACE(*s)) s++;
2d8e6c8d 3094 for (s2 = s; (s2 > SvPV(PL_linestr,n_a)+2 &&
6e72f9df 3095 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
3096 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
cea2e8a9 3097 Perl_croak(aTHX_ "Not a perl script");
a687059c 3098 while (*s == ' ' || *s == '\t') s++;
13281fa4
LW		 3099 /*
3100 * #! arg must be what we saw above. They can invoke it by
3101 * mentioning suidperl explicitly, but they may not add any strange
3102 * arguments beyond what #! says if they do invoke suidperl that way.
3103 */
3104 len = strlen(validarg);
3105 if (strEQ(validarg," PHOOEY ") ||
45d8adaa 3106 strnNE(s,validarg,len) || !isSPACE(s[len]))
cea2e8a9 3107 Perl_croak(aTHX_ "Args must match #! line");
a687059c
LW		 3108
3109#ifndef IAMSUID
b28d0864
NIS		 3110 if (PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
3111 PL_euid == PL_statbuf.st_uid)
3112 if (!PL_do_undump)
cea2e8a9 3113 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
a687059c
LW		 3114FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
3115#endif /* IAMSUID */
13281fa4 3116
b28d0864
NIS		 3117 if (PL_euid) { /* oops, we're not the setuid root perl */
3118 (void)PerlIO_close(PL_rsfp);
13281fa4 3119#ifndef IAMSUID
46fc3d4c 3120 /* try again */
a7cb1f99 3121 PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, BIN_EXP,
273cf8d1
GS		 3122 (int)PERL_REVISION, (int)PERL_VERSION,
3123 (int)PERL_SUBVERSION), PL_origargv);
13281fa4 3124#endif
cea2e8a9 3125 Perl_croak(aTHX_ "Can't do setuid\n");
13281fa4
LW		 3126 }
3127
b28d0864 3128 if (PL_statbuf.st_mode & S_ISGID && PL_statbuf.st_gid != PL_egid) {
fe14fcc3 3129#ifdef HAS_SETEGID
b28d0864 3130 (void)setegid(PL_statbuf.st_gid);
a687059c 3131#else
fe14fcc3 3132#ifdef HAS_SETREGID
b28d0864 3133 (void)setregid((Gid_t)-1,PL_statbuf.st_gid);
85e6fe83
LW		 3134#else
3135#ifdef HAS_SETRESGID
b28d0864 3136 (void)setresgid((Gid_t)-1,PL_statbuf.st_gid,(Gid_t)-1);
a687059c 3137#else
b28d0864 3138 PerlProc_setgid(PL_statbuf.st_gid);
a687059c
LW		 3139#endif
3140#endif
85e6fe83 3141#endif
b28d0864 3142 if (PerlProc_getegid() != PL_statbuf.st_gid)
cea2e8a9 3143 Perl_croak(aTHX_ "Can't do setegid!\n");
83025b21 3144 }
b28d0864
NIS		 3145 if (PL_statbuf.st_mode & S_ISUID) {
3146 if (PL_statbuf.st_uid != PL_euid)
fe14fcc3 3147#ifdef HAS_SETEUID
b28d0864 3148 (void)seteuid(PL_statbuf.st_uid); /* all that for this */
a687059c 3149#else
fe14fcc3 3150#ifdef HAS_SETREUID
b28d0864 3151 (void)setreuid((Uid_t)-1,PL_statbuf.st_uid);
85e6fe83
LW		 3152#else
3153#ifdef HAS_SETRESUID
b28d0864 3154 (void)setresuid((Uid_t)-1,PL_statbuf.st_uid,(Uid_t)-1);
a687059c 3155#else
b28d0864 3156 PerlProc_setuid(PL_statbuf.st_uid);
a687059c
LW		 3157#endif
3158#endif
85e6fe83 3159#endif
b28d0864 3160 if (PerlProc_geteuid() != PL_statbuf.st_uid)
cea2e8a9 3161 Perl_croak(aTHX_ "Can't do seteuid!\n");
a687059c 3162 }
b28d0864 3163 else if (PL_uid) { /* oops, mustn't run as root */
fe14fcc3 3164#ifdef HAS_SETEUID
b28d0864 3165 (void)seteuid((Uid_t)PL_uid);
a687059c 3166#else
fe14fcc3 3167#ifdef HAS_SETREUID
b28d0864 3168 (void)setreuid((Uid_t)-1,(Uid_t)PL_uid);
a687059c 3169#else
85e6fe83 3170#ifdef HAS_SETRESUID
b28d0864 3171 (void)setresuid((Uid_t)-1,(Uid_t)PL_uid,(Uid_t)-1);
85e6fe83 3172#else
b28d0864 3173 PerlProc_setuid((Uid_t)PL_uid);
85e6fe83 3174#endif
a687059c
LW		 3175#endif
3176#endif
b28d0864 3177 if (PerlProc_geteuid() != PL_uid)
cea2e8a9 3178 Perl_croak(aTHX_ "Can't do seteuid!\n");
83025b21 3179 }
748a9306 3180 init_ids();
b28d0864 3181 if (!cando(S_IXUSR,TRUE,&PL_statbuf))
cea2e8a9 3182 Perl_croak(aTHX_ "Permission denied\n"); /* they can't do this */
13281fa4
LW		 3183 }
3184#ifdef IAMSUID
6b88bc9c 3185 else if (PL_preprocess)
cea2e8a9 3186 Perl_croak(aTHX_ "-P not allowed for setuid/setgid script\n");
96436eeb 3187 else if (fdscript >= 0)
cea2e8a9 3188 Perl_croak(aTHX_ "fd script not allowed in suidperl\n");
13281fa4 3189 else
cea2e8a9 3190 Perl_croak(aTHX_ "Script is not setuid/setgid in suidperl\n");
96436eeb 3191
3192 /* We absolutely must clear out any saved ids here, so we */
3193 /* exec the real perl, substituting fd script for scriptname. */
3194 /* (We pass script name as "subdir" of fd, which perl will grok.) */
b28d0864
NIS		 3195 PerlIO_rewind(PL_rsfp);
3196 PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0); /* just in case rewind didn't */
6b88bc9c
GS		 3197 for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;
3198 if (!PL_origargv[which])
cea2e8a9
GS		 3199 Perl_croak(aTHX_ "Permission denied");
3200 PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s",
6b88bc9c 3201 PerlIO_fileno(PL_rsfp), PL_origargv[which]));
96436eeb 3202#if defined(HAS_FCNTL) && defined(F_SETFD)
b28d0864 3203 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0); /* ensure no close-on-exec */
96436eeb 3204#endif
a7cb1f99 3205 PerlProc_execv(Perl_form(aTHX_ "%s/perl"PERL_FS_VER_FMT, BIN_EXP,
273cf8d1
GS		 3206 (int)PERL_REVISION, (int)PERL_VERSION,
3207 (int)PERL_SUBVERSION), PL_origargv);/* try again */
cea2e8a9 3208 Perl_croak(aTHX_ "Can't do setuid\n");
13281fa4 3209#endif /* IAMSUID */
a687059c 3210#else /* !DOSUID */
3280af22 3211 if (PL_euid != PL_uid || PL_egid != PL_gid) { /* (suidperl doesn't exist, in fact) */
a687059c 3212#ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
b28d0864
NIS		 3213 PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf); /* may be either wrapped or real suid */
3214 if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
a687059c 3215 ||
b28d0864 3216 (PL_egid != PL_gid && PL_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
a687059c 3217 )
b28d0864 3218 if (!PL_do_undump)
cea2e8a9 3219 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
a687059c
LW		 3220FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
3221#endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
3222 /* not set-id, must be wrapped */
a687059c 3223 }
13281fa4 3224#endif /* DOSUID */
79072805 3225}
13281fa4 3226
76e3520e 3227STATIC void
cea2e8a9 3228S_find_beginning(pTHX)
79072805 3229{
6e72f9df 3230 register char *s, *s2;
33b78306
LW		 3231
3232 /* skip forward in input to the real script? */
3233
bbce6d69 3234 forbid_setid("-x");
bf4acbe4 3235#ifdef MACOS_TRADITIONAL
084592ab 3236 /* Since the Mac OS does not honor #! arguments for us, we do it ourselves */
ac27b0f5 3237
bf4acbe4
GS		 3238 while (PL_doextract || gMacPerl_AlwaysExtract) {
3239 if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
3240 if (!gMacPerl_AlwaysExtract)
3241 Perl_croak(aTHX_ "No Perl script found in input\n");
3242
3243 if (PL_doextract) /* require explicit override ? */
3244 if (!OverrideExtract(PL_origfilename))
3245 Perl_croak(aTHX_ "User aborted script\n");
3246 else
3247 PL_doextract = FALSE;
3248
3249 /* Pater peccavi, file does not have #! */
3250 PerlIO_rewind(PL_rsfp);
ac27b0f5 3251
bf4acbe4
GS		 3252 break;
3253 }
3254#else
3280af22
NIS		 3255 while (PL_doextract) {
3256 if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch)
cea2e8a9 3257 Perl_croak(aTHX_ "No Perl script found in input\n");
bf4acbe4 3258#endif
4f0c37ba
IZ		 3259 s2 = s;
3260 if (*s == '#' && s[1] == '!' && ((s = instr(s,"perl")) || (s = instr(s2,"PERL")))) {
3280af22
NIS		 3261 PerlIO_ungetc(PL_rsfp, '\n'); /* to keep line count right */
3262 PL_doextract = FALSE;
6e72f9df 3263 while (*s && !(isSPACE (*s) || *s == '#')) s++;
3264 s2 = s;
3265 while (*s == ' ' || *s == '\t') s++;
3266 if (*s++ == '-') {
3267 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
3268 if (strnEQ(s2-4,"perl",4))
3269 /*SUPPRESS 530*/
155aba94
GS		 3270 while ((s = moreswitches(s)))
3271 ;
33b78306 3272 }
95e8664e
CN		 3273#ifdef MACOS_TRADITIONAL
3274 break;
3275#endif
83025b21
LW		 3276 }
3277 }
3278}
3279
afe37c7d 3280
76e3520e 3281STATIC void
cea2e8a9 3282S_init_ids(pTHX)
352d5a3a 3283{
d8eceb89
JH		 3284 PL_uid = PerlProc_getuid();
3285 PL_euid = PerlProc_geteuid();
3286 PL_gid = PerlProc_getgid();
3287 PL_egid = PerlProc_getegid();
748a9306 3288#ifdef VMS
b28d0864
NIS		 3289 PL_uid |= PL_gid << 16;
3290 PL_euid |= PL_egid << 16;
748a9306 3291#endif
3280af22 3292 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
748a9306 3293}
79072805 3294
76e3520e 3295STATIC void
cea2e8a9 3296S_forbid_setid(pTHX_ char *s)
bbce6d69 3297{
3280af22 3298 if (PL_euid != PL_uid)
cea2e8a9 3299 Perl_croak(aTHX_ "No %s allowed while running setuid", s);
3280af22 3300 if (PL_egid != PL_gid)
cea2e8a9 3301 Perl_croak(aTHX_ "No %s allowed while running setgid", s);
bbce6d69 3302}
3303
1ee4443e
IZ		 3304void
3305Perl_init_debugger(pTHX)
748a9306 3306{
1ee4443e
IZ		 3307 HV *ostash = PL_curstash;
3308
3280af22
NIS		 3309 PL_curstash = PL_debstash;
3310 PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
3311 AvREAL_off(PL_dbargs);
3312 PL_DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
3313 PL_DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
3314 PL_DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
1ee4443e 3315 sv_upgrade(GvSV(PL_DBsub), SVt_IV); /* IVX accessed if PERLDB_SUB_NN */
3280af22 3316 PL_DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
ac27b0f5 3317 sv_setiv(PL_DBsingle, 0);
3280af22 3318 PL_DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
ac27b0f5 3319 sv_setiv(PL_DBtrace, 0);
3280af22 3320 PL_DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
ac27b0f5 3321 sv_setiv(PL_DBsignal, 0);
1ee4443e 3322 PL_curstash = ostash;
352d5a3a
LW		 3323}
3324
2ce36478
SM		 3325#ifndef STRESS_REALLOC
3326#define REASONABLE(size) (size)
3327#else
3328#define REASONABLE(size) (1) /* unreasonable */
3329#endif
3330
11343788 3331void
cea2e8a9 3332Perl_init_stacks(pTHX)
79072805 3333{
e336de0d 3334 /* start with 128-item stack and 8K cxstack */
3280af22 3335 PL_curstackinfo = new_stackinfo(REASONABLE(128),
e336de0d 3336 REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
3280af22
NIS		 3337 PL_curstackinfo->si_type = PERLSI_MAIN;
3338 PL_curstack = PL_curstackinfo->si_stack;
3339 PL_mainstack = PL_curstack; /* remember in case we switch stacks */
79072805 3340
3280af22
NIS		 3341 PL_stack_base = AvARRAY(PL_curstack);
3342 PL_stack_sp = PL_stack_base;
3343 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
8990e307 3344
3280af22
NIS		 3345 New(50,PL_tmps_stack,REASONABLE(128),SV*);
3346 PL_tmps_floor = -1;
3347 PL_tmps_ix = -1;
3348 PL_tmps_max = REASONABLE(128);
8990e307 3349
3280af22
NIS		 3350 New(54,PL_markstack,REASONABLE(32),I32);
3351 PL_markstack_ptr = PL_markstack;
3352 PL_markstack_max = PL_markstack + REASONABLE(32);
79072805 3353
ce2f7c3b 3354 SET_MARK_OFFSET;
e336de0d 3355
3280af22
NIS		 3356 New(54,PL_scopestack,REASONABLE(32),I32);
3357 PL_scopestack_ix = 0;
3358 PL_scopestack_max = REASONABLE(32);
79072805 3359
3280af22
NIS		 3360 New(54,PL_savestack,REASONABLE(128),ANY);
3361 PL_savestack_ix = 0;
3362 PL_savestack_max = REASONABLE(128);
79072805 3363
3280af22
NIS		 3364 New(54,PL_retstack,REASONABLE(16),OP*);
3365 PL_retstack_ix = 0;
3366 PL_retstack_max = REASONABLE(16);
378cc40b 3367}
33b78306 3368
2ce36478
SM		 3369#undef REASONABLE
3370
76e3520e 3371STATIC void
cea2e8a9 3372S_nuke_stacks(pTHX)
6e72f9df 3373{
3280af22
NIS		 3374 while (PL_curstackinfo->si_next)
3375 PL_curstackinfo = PL_curstackinfo->si_next;
3376 while (PL_curstackinfo) {
3377 PERL_SI *p = PL_curstackinfo->si_prev;
bac4b2ad 3378 /* curstackinfo->si_stack got nuked by sv_free_arenas() */
3280af22
NIS		 3379 Safefree(PL_curstackinfo->si_cxstack);
3380 Safefree(PL_curstackinfo);
3381 PL_curstackinfo = p;
e336de0d 3382 }
3280af22
NIS		 3383 Safefree(PL_tmps_stack);
3384 Safefree(PL_markstack);
3385 Safefree(PL_scopestack);
3386 Safefree(PL_savestack);
3387 Safefree(PL_retstack);
378cc40b 3388}
33b78306 3389
76e3520e 3390STATIC void
cea2e8a9 3391S_init_lexer(pTHX)
8990e307 3392{
06039172 3393 PerlIO *tmpfp;
3280af22
NIS		 3394 tmpfp = PL_rsfp;
3395 PL_rsfp = Nullfp;
3396 lex_start(PL_linestr);
3397 PL_rsfp = tmpfp;
79cb57f6 3398 PL_subname = newSVpvn("main",4);
8990e307
LW		 3399}
3400
76e3520e 3401STATIC void
cea2e8a9 3402S_init_predump_symbols(pTHX)
45d8adaa 3403{
93a17b20 3404 GV *tmpgv;
af8c498a 3405 IO *io;
79072805 3406
864dbfa3 3407 sv_setpvn(get_sv("\"", TRUE), " ", 1);
3280af22
NIS		 3408 PL_stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
3409 GvMULTI_on(PL_stdingv);
af8c498a 3410 io = GvIOp(PL_stdingv);
a04651f4 3411 IoTYPE(io) = IoTYPE_RDONLY;
af8c498a 3412 IoIFP(io) = PerlIO_stdin();
adbc6bb1 3413 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
a5f75d66 3414 GvMULTI_on(tmpgv);
af8c498a 3415 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
79072805 3416
85e6fe83 3417 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
a5f75d66 3418 GvMULTI_on(tmpgv);
af8c498a 3419 io = GvIOp(tmpgv);
a04651f4 3420 IoTYPE(io) = IoTYPE_WRONLY;
af8c498a 3421 IoOFP(io) = IoIFP(io) = PerlIO_stdout();
4633a7c4 3422 setdefout(tmpgv);
adbc6bb1 3423 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
a5f75d66 3424 GvMULTI_on(tmpgv);
af8c498a 3425 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
79072805 3426
bf49b057
GS		 3427 PL_stderrgv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
3428 GvMULTI_on(PL_stderrgv);
3429 io = GvIOp(PL_stderrgv);
a04651f4 3430 IoTYPE(io) = IoTYPE_WRONLY;
af8c498a 3431 IoOFP(io) = IoIFP(io) = PerlIO_stderr();
adbc6bb1 3432 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
a5f75d66 3433 GvMULTI_on(tmpgv);
af8c498a 3434 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
79072805 3435
3280af22 3436 PL_statname = NEWSV(66,0); /* last filename we did stat on */
ab821d7f 3437
bf4acbe4
GS		 3438 if (PL_osname)
3439 Safefree(PL_osname);
3440 PL_osname = savepv(OSNAME);
79072805 3441}
33b78306 3442
a11ec5a9
RGS		 3443void
3444Perl_init_argv_symbols(pTHX_ register int argc, register char **argv)
33b78306 3445{
79072805 3446 char *s;
79072805 3447 argc--,argv++; /* skip name of script */
3280af22 3448 if (PL_doswitches) {
79072805
LW		 3449 for (; argc > 0 && **argv == '-'; argc--,argv++) {
3450 if (!argv[0][1])
3451 break;
379d538a 3452 if (argv[0][1] == '-' && !argv[0][2]) {
79072805
LW		 3453 argc--,argv++;
3454 break;
3455 }
155aba94 3456 if ((s = strchr(argv[0], '='))) {
79072805 3457 *s++ = '\0';
85e6fe83 3458 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
79072805
LW		 3459 }
3460 else
85e6fe83 3461 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
fe14fcc3 3462 }
79072805 3463 }
a11ec5a9
RGS		 3464 if ((PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV))) {
3465 GvMULTI_on(PL_argvgv);
3466 (void)gv_AVadd(PL_argvgv);
3467 av_clear(GvAVn(PL_argvgv));
3468 for (; argc > 0; argc--,argv++) {
3469 SV *sv = newSVpv(argv[0],0);
3470 av_push(GvAVn(PL_argvgv),sv);
3471 if (PL_widesyscalls)
3472 (void)sv_utf8_decode(sv);
3473 }
3474 }
d8c55666
MJD		 3475
3476 if (PL_minus_a) {
3477 (void) get_av("main::F", TRUE | GV_ADDMULTI);
3478 }
a11ec5a9
RGS		 3479}
3480
04fee9b5
NIS		 3481#ifdef HAS_PROCSELFEXE
3482/* This is a function so that we don't hold on to MAXPATHLEN
8338e367 3483 bytes of stack longer than necessary
04fee9b5
NIS		 3484 */
3485STATIC void
3486S_procself_val(pTHX_ SV *sv, char *arg0)
3487{
3488 char buf[MAXPATHLEN];
d13a6521 3489 int len = readlink(PROCSELFEXE_PATH, buf, sizeof(buf) - 1);
d103ec31
JH		 3490 /* FreeBSD's implementation is acknowledged to be imperfect, sometimes
3491 returning the text "unknown" from the readlink rather than the path
78cb7c00 3492 to the executable (or returning an error from the readlink). Any valid
d103ec31
JH		 3493 path has a '/' in it somewhere, so use that to validate the result.
3494 See http://www.freebsd.org/cgi/query-pr.cgi?pr=35703
3495 */
78cb7c00 3496 if (len > 0 && memchr(buf, '/', len)) {
04fee9b5
NIS		 3497 sv_setpvn(sv,buf,len);
3498 }
3499 else {
3500 sv_setpv(sv,arg0);
3501 }
3502}
3503#endif /* HAS_PROCSELFEXE */
3504
a11ec5a9
RGS		 3505STATIC void
3506S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
3507{
3508 char *s;
3509 SV *sv;
3510 GV* tmpgv;
a11ec5a9 3511
3280af22
NIS		 3512 PL_toptarget = NEWSV(0,0);
3513 sv_upgrade(PL_toptarget, SVt_PVFM);
3514 sv_setpvn(PL_toptarget, "", 0);
3515 PL_bodytarget = NEWSV(0,0);
3516 sv_upgrade(PL_bodytarget, SVt_PVFM);
3517 sv_setpvn(PL_bodytarget, "", 0);
3518 PL_formtarget = PL_bodytarget;
79072805 3519
bbce6d69 3520 TAINT;
a11ec5a9
RGS		 3521
3522 init_argv_symbols(argc,argv);
3523
155aba94 3524 if ((tmpgv = gv_fetchpv("0",TRUE, SVt_PV))) {
bf4acbe4
GS		 3525#ifdef MACOS_TRADITIONAL
3526 /* $0 is not majick on a Mac */
3527 sv_setpv(GvSV(tmpgv),MacPerl_MPWFileName(PL_origfilename));
3528#else
3280af22 3529 sv_setpv(GvSV(tmpgv),PL_origfilename);
79072805 3530 magicname("0", "0", 1);
bf4acbe4 3531#endif
79072805 3532 }
04fee9b5
NIS		 3533 if ((tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))) {/* $^X */
3534#ifdef HAS_PROCSELFEXE
3535 S_procself_val(aTHX_ GvSV(tmpgv), PL_origargv[0]);
3536#else
8338e367 3537#ifdef OS2
23da6c43 3538 sv_setpv(GvSV(tmpgv), os2_execname(aTHX));
8338e367
JH		 3539#else
3540 sv_setpv(GvSV(tmpgv),PL_origargv[0]);
3541#endif
04fee9b5
NIS		 3542#endif
3543 }
155aba94 3544 if ((PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV))) {
79072805 3545 HV *hv;
3280af22
NIS		 3546 GvMULTI_on(PL_envgv);
3547 hv = GvHVn(PL_envgv);
14befaf4 3548 hv_magic(hv, Nullgv, PERL_MAGIC_env);
fa6a1c44 3549#ifdef USE_ENVIRON_ARRAY
4633a7c4
LW		 3550 /* Note that if the supplied env parameter is actually a copy
3551 of the global environ then it may now point to free'd memory
3552 if the environment has been modified since. To avoid this
3553 problem we treat env==NULL as meaning 'use the default'
3554 */
3555 if (!env)
3556 env = environ;
5aabfad6 3557 if (env != environ)
79072805 3558 environ[0] = Nullch;
764df951
IZ		 3559 if (env)
3560 for (; *env; env++) {
93a17b20 3561 if (!(s = strchr(*env,'=')))
79072805 3562 continue;
60ce6247 3563#if defined(MSDOS)
61968511 3564 *s = '\0';
137443ea 3565 (void)strupr(*env);
61968511 3566 *s = '=';
137443ea 3567#endif
61968511 3568 sv = newSVpv(s+1, 0);
79072805 3569 (void)hv_store(hv, *env, s - *env, sv, 0);
61968511
GA		 3570 if (env != environ)
3571 mg_set(sv);
764df951 3572 }
103a7189 3573#endif /* USE_ENVIRON_ARRAY */
79072805 3574 }
bbce6d69 3575 TAINT_NOT;
306196c3
MS		 3576 if ((tmpgv = gv_fetchpv("$",TRUE, SVt_PV))) {
3577 SvREADONLY_off(GvSV(tmpgv));
7766f137 3578 sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
306196c3
MS		 3579 SvREADONLY_on(GvSV(tmpgv));
3580 }
33b78306 3581}
34de22dd 3582
76e3520e 3583STATIC void
cea2e8a9 3584S_init_perllib(pTHX)
34de22dd 3585{
85e6fe83 3586 char *s;
3280af22 3587 if (!PL_tainting) {
552a7a9b 3588#ifndef VMS
76e3520e 3589 s = PerlEnv_getenv("PERL5LIB");
85e6fe83 3590 if (s)
9c8a64f0 3591 incpush(s, TRUE, TRUE);
85e6fe83 3592 else
9c8a64f0 3593 incpush(PerlEnv_getenv("PERLLIB"), FALSE, FALSE);
552a7a9b 3594#else /* VMS */
3595 /* Treat PERL5?LIB as a possible search list logical name -- the
3596 * "natural" VMS idiom for a Unix path string. We allow each
3597 * element to be a set of |-separated directories for compatibility.
3598 */
3599 char buf[256];
3600 int idx = 0;
3601 if (my_trnlnm("PERL5LIB",buf,0))
9c8a64f0 3602 do { incpush(buf,TRUE,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
552a7a9b 3603 else
9c8a64f0 3604 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE,FALSE);
552a7a9b 3605#endif /* VMS */
85e6fe83 3606 }
34de22dd 3607
c90c0ff4 3608/* Use the ~-expanded versions of APPLLIB (undocumented),
65f19062 3609 ARCHLIB PRIVLIB SITEARCH SITELIB VENDORARCH and VENDORLIB
df5cef82 3610*/
4633a7c4 3611#ifdef APPLLIB_EXP
9c8a64f0 3612 incpush(APPLLIB_EXP, TRUE, TRUE);
16d20bd9 3613#endif
4633a7c4 3614
fed7345c 3615#ifdef ARCHLIB_EXP
9c8a64f0 3616 incpush(ARCHLIB_EXP, FALSE, FALSE);
a0d0e21e 3617#endif
bf4acbe4
GS		 3618#ifdef MACOS_TRADITIONAL
3619 {
3620 struct stat tmpstatbuf;
3621 SV * privdir = NEWSV(55, 0);
3622 char * macperl = PerlEnv_getenv("MACPERL");
3623
3624 if (!macperl)
3625 macperl = "";
3626
3627 Perl_sv_setpvf(aTHX_ privdir, "%slib:", macperl);
3628 if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode))
3629 incpush(SvPVX(privdir), TRUE, FALSE);
3630 Perl_sv_setpvf(aTHX_ privdir, "%ssite_perl:", macperl);
3631 if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode))
3632 incpush(SvPVX(privdir), TRUE, FALSE);
ac27b0f5 3633
bf4acbe4
GS		 3634 SvREFCNT_dec(privdir);
3635 }
3636 if (!PL_tainting)
3637 incpush(":", FALSE, FALSE);
3638#else
fed7345c 3639#ifndef PRIVLIB_EXP
65f19062 3640# define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
34de22dd 3641#endif
ac27b0f5 3642#if defined(WIN32)
9c8a64f0 3643 incpush(PRIVLIB_EXP, TRUE, FALSE);
00dc2f4f 3644#else
9c8a64f0 3645 incpush(PRIVLIB_EXP, FALSE, FALSE);
00dc2f4f 3646#endif
4633a7c4 3647
65f19062 3648#ifdef SITEARCH_EXP
3b290362
GS		 3649 /* sitearch is always relative to sitelib on Windows for
3650 * DLL-based path intuition to work correctly */
3651# if !defined(WIN32)
9c8a64f0 3652 incpush(SITEARCH_EXP, FALSE, FALSE);
65f19062
GS		 3653# endif
3654#endif
3655
4633a7c4 3656#ifdef SITELIB_EXP
65f19062 3657# if defined(WIN32)
9c8a64f0 3658 incpush(SITELIB_EXP, TRUE, FALSE); /* this picks up sitearch as well */
65f19062 3659# else
9c8a64f0 3660 incpush(SITELIB_EXP, FALSE, FALSE);
65f19062
GS		 3661# endif
3662#endif
189d1e8d 3663
65f19062 3664#ifdef SITELIB_STEM /* Search for version-specific dirs below here */
9c8a64f0 3665 incpush(SITELIB_STEM, FALSE, TRUE);
81c6dfba 3666#endif
65f19062
GS		 3667
3668#ifdef PERL_VENDORARCH_EXP
4ea817c6 3669 /* vendorarch is always relative to vendorlib on Windows for
3b290362
GS		 3670 * DLL-based path intuition to work correctly */
3671# if !defined(WIN32)
9c8a64f0 3672 incpush(PERL_VENDORARCH_EXP, FALSE, FALSE);
65f19062 3673# endif
4b03c463 3674#endif
65f19062
GS		 3675
3676#ifdef PERL_VENDORLIB_EXP
3677# if defined(WIN32)
9c8a64f0 3678 incpush(PERL_VENDORLIB_EXP, TRUE, FALSE); /* this picks up vendorarch as well */
65f19062 3679# else
9c8a64f0 3680 incpush(PERL_VENDORLIB_EXP, FALSE, FALSE);
65f19062 3681# endif
a3635516 3682#endif
65f19062
GS		 3683
3684#ifdef PERL_VENDORLIB_STEM /* Search for version-specific dirs below here */
9c8a64f0 3685 incpush(PERL_VENDORLIB_STEM, FALSE, TRUE);
00dc2f4f 3686#endif
65f19062 3687
3b777bb4
GS		 3688#ifdef PERL_OTHERLIBDIRS
3689 incpush(PERL_OTHERLIBDIRS, TRUE, TRUE);
3690#endif
3691
3280af22 3692 if (!PL_tainting)
9c8a64f0 3693 incpush(".", FALSE, FALSE);
bf4acbe4 3694#endif /* MACOS_TRADITIONAL */
774d564b 3695}
3696
ed79a026 3697#if defined(DOSISH) || defined(EPOC)
774d564b 3698# define PERLLIB_SEP ';'
3699#else
3700# if defined(VMS)
3701# define PERLLIB_SEP '|'
3702# else
bf4acbe4
GS		 3703# if defined(MACOS_TRADITIONAL)
3704# define PERLLIB_SEP ','
3705# else
3706# define PERLLIB_SEP ':'
3707# endif
774d564b 3708# endif
3709#endif
3710#ifndef PERLLIB_MANGLE
3711# define PERLLIB_MANGLE(s,n) (s)
ac27b0f5 3712#endif
774d564b 3713
76e3520e 3714STATIC void
9c8a64f0 3715S_incpush(pTHX_ char *p, int addsubdirs, int addoldvers)
774d564b 3716{
3717 SV *subdir = Nullsv;
774d564b 3718
3b290362 3719 if (!p || !*p)
774d564b 3720 return;
3721
9c8a64f0 3722 if (addsubdirs || addoldvers) {
00db4c45 3723 subdir = sv_newmortal();
774d564b 3724 }
3725
3726 /* Break at all separators */
3727 while (p && *p) {
8c52afec 3728 SV *libdir = NEWSV(55,0);
774d564b 3729 char *s;
3730
3731 /* skip any consecutive separators */
3732 while ( *p == PERLLIB_SEP ) {
3733 /* Uncomment the next line for PATH semantics */
79cb57f6 3734 /* av_push(GvAVn(PL_incgv), newSVpvn(".", 1)); */
774d564b 3735 p++;
3736 }
3737
3738 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
3739 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
3740 (STRLEN)(s - p));
3741 p = s + 1;
3742 }
3743 else {
3744 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
3745 p = Nullch; /* break out */
3746 }
bf4acbe4
GS		 3747#ifdef MACOS_TRADITIONAL
3748 if (!strchr(SvPVX(libdir), ':'))
3749 sv_insert(libdir, 0, 0, ":", 1);
3750 if (SvPVX(libdir)[SvCUR(libdir)-1] != ':')
3751 sv_catpv(libdir, ":");
3752#endif
774d564b 3753
3754 /*
3755 * BEFORE pushing libdir onto @INC we may first push version- and
3756 * archname-specific sub-directories.
3757 */
9c8a64f0 3758 if (addsubdirs || addoldvers) {
29d82f8d 3759#ifdef PERL_INC_VERSION_LIST
8353b874
GS		 3760 /* Configure terminates PERL_INC_VERSION_LIST with a NULL */
3761 const char *incverlist[] = { PERL_INC_VERSION_LIST };
29d82f8d
GS		 3762 const char **incver;
3763#endif
774d564b 3764 struct stat tmpstatbuf;
aa689395 3765#ifdef VMS
3766 char *unix;
3767 STRLEN len;
774d564b 3768
2d8e6c8d 3769 if ((unix = tounixspec_ts(SvPV(libdir,len),Nullch)) != Nullch) {
aa689395 3770 len = strlen(unix);
3771 while (unix[len-1] == '/') len--; /* Cosmetic */
3772 sv_usepvn(libdir,unix,len);
3773 }
3774 else
bf49b057 3775 PerlIO_printf(Perl_error_log,
aa689395 3776 "Failed to unixify @INC element \"%s\"\n",
2d8e6c8d 3777 SvPV(libdir,len));
aa689395 3778#endif
9c8a64f0 3779 if (addsubdirs) {
bf4acbe4
GS		 3780#ifdef MACOS_TRADITIONAL
3781#define PERL_AV_SUFFIX_FMT ""
084592ab
CN		 3782#define PERL_ARCH_FMT "%s:"
3783#define PERL_ARCH_FMT_PATH PERL_FS_VER_FMT PERL_AV_SUFFIX_FMT
bf4acbe4
GS		 3784#else
3785#define PERL_AV_SUFFIX_FMT "/"
3786#define PERL_ARCH_FMT "/%s"
084592ab 3787#define PERL_ARCH_FMT_PATH PERL_AV_SUFFIX_FMT PERL_FS_VER_FMT
bf4acbe4 3788#endif
9c8a64f0 3789 /* .../version/archname if -d .../version/archname */
084592ab 3790 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH PERL_ARCH_FMT,
9c8a64f0
GS		 3791 libdir,
3792 (int)PERL_REVISION, (int)PERL_VERSION,
3793 (int)PERL_SUBVERSION, ARCHNAME);
3794 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3795 S_ISDIR(tmpstatbuf.st_mode))
3796 av_push(GvAVn(PL_incgv), newSVsv(subdir));
4b03c463 3797
9c8a64f0 3798 /* .../version if -d .../version */
084592ab 3799 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH, libdir,
9c8a64f0
GS		 3800 (int)PERL_REVISION, (int)PERL_VERSION,
3801 (int)PERL_SUBVERSION);
3802 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3803 S_ISDIR(tmpstatbuf.st_mode))
3804 av_push(GvAVn(PL_incgv), newSVsv(subdir));
3805
3806 /* .../archname if -d .../archname */
bf4acbe4 3807 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, libdir, ARCHNAME);
29d82f8d
GS		 3808 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3809 S_ISDIR(tmpstatbuf.st_mode))
3810 av_push(GvAVn(PL_incgv), newSVsv(subdir));
29d82f8d 3811 }
9c8a64f0 3812
9c8a64f0 3813#ifdef PERL_INC_VERSION_LIST
ccc2aad8 3814 if (addoldvers) {
9c8a64f0
GS		 3815 for (incver = incverlist; *incver; incver++) {
3816 /* .../xxx if -d .../xxx */
bf4acbe4 3817 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, libdir, *incver);
9c8a64f0
GS		 3818 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3819 S_ISDIR(tmpstatbuf.st_mode))
3820 av_push(GvAVn(PL_incgv), newSVsv(subdir));
3821 }
3822 }
29d82f8d 3823#endif
774d564b 3824 }
3825
3826 /* finally push this lib directory on the end of @INC */
3280af22 3827 av_push(GvAVn(PL_incgv), libdir);
774d564b 3828 }
34de22dd 3829}
93a17b20 3830
4d1ff10f 3831#ifdef USE_5005THREADS
76e3520e 3832STATIC struct perl_thread *
cea2e8a9 3833S_init_main_thread(pTHX)
199100c8 3834{
c5be433b 3835#if !defined(PERL_IMPLICIT_CONTEXT)
52e1cb5e 3836 struct perl_thread *thr;
cea2e8a9 3837#endif
199100c8
MB		 3838 XPV *xpv;
3839
52e1cb5e 3840 Newz(53, thr, 1, struct perl_thread);
533c011a 3841 PL_curcop = &PL_compiling;
c5be433b 3842 thr->interp = PERL_GET_INTERP;
199100c8 3843 thr->cvcache = newHV();
54b9620d 3844 thr->threadsv = newAV();
940cb80d 3845 /* thr->threadsvp is set when find_threadsv is called */
199100c8
MB		 3846 thr->specific = newAV();
3847 thr->flags = THRf_R_JOINABLE;
3848 MUTEX_INIT(&thr->mutex);
3849 /* Handcraft thrsv similarly to mess_sv */
533c011a 3850 New(53, PL_thrsv, 1, SV);
199100c8 3851 Newz(53, xpv, 1, XPV);
533c011a
NIS		 3852 SvFLAGS(PL_thrsv) = SVt_PV;
3853 SvANY(PL_thrsv) = (void*)xpv;
3854 SvREFCNT(PL_thrsv) = 1 << 30; /* practically infinite */
3855 SvPVX(PL_thrsv) = (char*)thr;
3856 SvCUR_set(PL_thrsv, sizeof(thr));
3857 SvLEN_set(PL_thrsv, sizeof(thr));
3858 *SvEND(PL_thrsv) = '\0'; /* in the trailing_nul field */
3859 thr->oursv = PL_thrsv;
3860 PL_chopset = " \n-";
3967c732 3861 PL_dumpindent = 4;
533c011a
NIS		 3862
3863 MUTEX_LOCK(&PL_threads_mutex);
3864 PL_nthreads++;
199100c8
MB		 3865 thr->tid = 0;
3866 thr->next = thr;
3867 thr->prev = thr;
8dcd6f7b 3868 thr->thr_done = 0;
533c011a 3869 MUTEX_UNLOCK(&PL_threads_mutex);
199100c8 3870
4b026b9e 3871#ifdef HAVE_THREAD_INTERN
4f63d024 3872 Perl_init_thread_intern(thr);
235db74f
GS		 3873#endif
3874
3875#ifdef SET_THREAD_SELF
3876 SET_THREAD_SELF(thr);
199100c8
MB		 3877#else
3878 thr->self = pthread_self();
235db74f 3879#endif /* SET_THREAD_SELF */
06d86050 3880 PERL_SET_THX(thr);
199100c8
MB		 3881
3882 /*
411caa50
JH		 3883 * These must come after the thread self setting
3884 * because sv_setpvn does SvTAINT and the taint
3885 * fields thread selfness being set.
199100c8 3886 */
533c011a
NIS		 3887 PL_toptarget = NEWSV(0,0);
3888 sv_upgrade(PL_toptarget, SVt_PVFM);
3889 sv_setpvn(PL_toptarget, "", 0);
3890 PL_bodytarget = NEWSV(0,0);
3891 sv_upgrade(PL_bodytarget, SVt_PVFM);
3892 sv_setpvn(PL_bodytarget, "", 0);
3893 PL_formtarget = PL_bodytarget;
79cb57f6 3894 thr->errsv = newSVpvn("", 0);
78857c3c 3895 (void) find_threadsv("@"); /* Ensure $@ is initialised early */
5c0ca799 3896
533c011a 3897 PL_maxscream = -1;
a2efc822 3898 PL_peepp = MEMBER_TO_FPTR(Perl_peep);
0b94c7bb
GS		 3899 PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp);
3900 PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags);
3901 PL_regint_start = MEMBER_TO_FPTR(Perl_re_intuit_start);
3902 PL_regint_string = MEMBER_TO_FPTR(Perl_re_intuit_string);
3903 PL_regfree = MEMBER_TO_FPTR(Perl_pregfree);
533c011a
NIS		 3904 PL_regindent = 0;
3905 PL_reginterp_cnt = 0;
5c0ca799 3906
199100c8
MB		 3907 return thr;
3908}
4d1ff10f 3909#endif /* USE_5005THREADS */
199100c8 3910
93a17b20 3911void
864dbfa3 3912Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
93a17b20 3913{
971a9dd3 3914 SV *atsv;
57843af0 3915 line_t oldline = CopLINE(PL_curcop);
312caa8e 3916 CV *cv;
22921e25 3917 STRLEN len;
6224f72b 3918 int ret;
db36c5a1 3919 dJMPENV;
93a17b20 3920
76e3520e 3921 while (AvFILL(paramList) >= 0) {
312caa8e 3922 cv = (CV*)av_shift(paramList);
aefff11f 3923 if (PL_savebegin && (paramList == PL_beginav)) {
059a8bb7
JH		 3924 /* save PL_beginav for compiler */
3925 if (! PL_beginav_save)
3926 PL_beginav_save = newAV();
3927 av_push(PL_beginav_save, (SV*)cv);
3928 } else {
3929 SAVEFREESV(cv);
3930 }
14dd3ad8
GS		 3931#ifdef PERL_FLEXIBLE_EXCEPTIONS
3932 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_list_body), cv);
3933#else
3934 JMPENV_PUSH(ret);
3935#endif
6224f72b 3936 switch (ret) {
312caa8e 3937 case 0:
14dd3ad8
GS		 3938#ifndef PERL_FLEXIBLE_EXCEPTIONS
3939 call_list_body(cv);
3940#endif
971a9dd3 3941 atsv = ERRSV;
312caa8e
CS		 3942 (void)SvPV(atsv, len);
3943 if (len) {
971a9dd3 3944 STRLEN n_a;
312caa8e 3945 PL_curcop = &PL_compiling;
57843af0 3946 CopLINE_set(PL_curcop, oldline);
312caa8e
CS		 3947 if (paramList == PL_beginav)
3948 sv_catpv(atsv, "BEGIN failed--compilation aborted");
3949 else
4f25aa18
GS		 3950 Perl_sv_catpvf(aTHX_ atsv,
3951 "%s failed--call queue aborted",
7d30b5c4 3952 paramList == PL_checkav ? "CHECK"
4f25aa18
GS		 3953 : paramList == PL_initav ? "INIT"
3954 : "END");
312caa8e
CS		 3955 while (PL_scopestack_ix > oldscope)
3956 LEAVE;
14dd3ad8 3957 JMPENV_POP;
971a9dd3 3958 Perl_croak(aTHX_ "%s", SvPVx(atsv, n_a));
a0d0e21e 3959 }
85e6fe83 3960 break;
6224f72b 3961 case 1:
f86702cc 3962 STATUS_ALL_FAILURE;
85e6fe83 3963 /* FALL THROUGH */
6224f72b 3964 case 2:
85e6fe83 3965 /* my_exit() was called */
3280af22 3966 while (PL_scopestack_ix > oldscope)
2ae324a7 3967 LEAVE;
84902520 3968 FREETMPS;
3280af22 3969 PL_curstash = PL_defstash;
3280af22 3970 PL_curcop = &PL_compiling;
57843af0 3971 CopLINE_set(PL_curcop, oldline);
14dd3ad8 3972 JMPENV_POP;
cc3604b1 3973 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED)) {
3280af22 3974 if (paramList == PL_beginav)
cea2e8a9 3975 Perl_croak(aTHX_ "BEGIN failed--compilation aborted");
85e6fe83 3976 else
4f25aa18 3977 Perl_croak(aTHX_ "%s failed--call queue aborted",
7d30b5c4 3978 paramList == PL_checkav ? "CHECK"
4f25aa18
GS		 3979 : paramList == PL_initav ? "INIT"
3980 : "END");
85e6fe83 3981 }
f86702cc 3982 my_exit_jump();
85e6fe83 3983 /* NOTREACHED */
6224f72b 3984 case 3:
312caa8e
CS		 3985 if (PL_restartop) {
3986 PL_curcop = &PL_compiling;
57843af0 3987 CopLINE_set(PL_curcop, oldline);
312caa8e 3988 JMPENV_JUMP(3);
85e6fe83 3989 }
bf49b057 3990 PerlIO_printf(Perl_error_log, "panic: restartop\n");
312caa8e
CS		 3991 FREETMPS;
3992 break;
8990e307 3993 }
14dd3ad8 3994 JMPENV_POP;
93a17b20 3995 }
93a17b20 3996}
93a17b20 3997
14dd3ad8 3998#ifdef PERL_FLEXIBLE_EXCEPTIONS
312caa8e 3999STATIC void *
14dd3ad8 4000S_vcall_list_body(pTHX_ va_list args)
312caa8e 4001{
312caa8e 4002 CV *cv = va_arg(args, CV*);
14dd3ad8
GS		 4003 return call_list_body(cv);
4004}
4005#endif
312caa8e 4006
14dd3ad8
GS		 4007STATIC void *
4008S_call_list_body(pTHX_ CV *cv)
4009{
312caa8e 4010 PUSHMARK(PL_stack_sp);
864dbfa3 4011 call_sv((SV*)cv, G_EVAL|G_DISCARD);
312caa8e
CS		 4012 return NULL;
4013}
4014
f86702cc 4015void
864dbfa3 4016Perl_my_exit(pTHX_ U32 status)
f86702cc 4017{
8b73bbec 4018 DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
a863c7d1 4019 thr, (unsigned long) status));
f86702cc 4020 switch (status) {
4021 case 0:
4022 STATUS_ALL_SUCCESS;
4023 break;
4024 case 1:
4025 STATUS_ALL_FAILURE;
4026 break;
4027 default:
4028 STATUS_NATIVE_SET(status);
4029 break;
4030 }
4031 my_exit_jump();
4032}
4033
4034void
864dbfa3 4035Perl_my_failure_exit(pTHX)
f86702cc 4036{
4037#ifdef VMS
4038 if (vaxc$errno & 1) {
4fdae800 4039 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
4040 STATUS_NATIVE_SET(44);
f86702cc 4041 }
4042 else {
ff0cee69 4043 if (!vaxc$errno && errno) /* unlikely */
4fdae800 4044 STATUS_NATIVE_SET(44);
f86702cc 4045 else
4fdae800 4046 STATUS_NATIVE_SET(vaxc$errno);
f86702cc 4047 }
4048#else
9b599b2a 4049 int exitstatus;
f86702cc 4050 if (errno & 255)
4051 STATUS_POSIX_SET(errno);
9b599b2a 4052 else {
ac27b0f5 4053 exitstatus = STATUS_POSIX >> 8;
9b599b2a
GS		 4054 if (exitstatus & 255)
4055 STATUS_POSIX_SET(exitstatus);
4056 else
4057 STATUS_POSIX_SET(255);
4058 }
f86702cc 4059#endif
4060 my_exit_jump();
93a17b20
LW		 4061}
4062
76e3520e 4063STATIC void
cea2e8a9 4064S_my_exit_jump(pTHX)
f86702cc 4065{
c09156bb 4066 register PERL_CONTEXT *cx;
f86702cc 4067 I32 gimme;
4068 SV **newsp;
4069
3280af22
NIS		 4070 if (PL_e_script) {
4071 SvREFCNT_dec(PL_e_script);
4072 PL_e_script = Nullsv;
f86702cc 4073 }
4074
3280af22 4075 POPSTACK_TO(PL_mainstack);
f86702cc 4076 if (cxstack_ix >= 0) {
4077 if (cxstack_ix > 0)
4078 dounwind(0);
3280af22 4079 POPBLOCK(cx,PL_curpm);
f86702cc 4080 LEAVE;
4081 }
ff0cee69 4082
6224f72b 4083 JMPENV_JUMP(2);
f86702cc 4084}
873ef191 4085
0cb96387 4086static I32
acfe0abc 4087read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen)
873ef191
GS		 4088{
4089 char *p, *nl;
3280af22 4090 p = SvPVX(PL_e_script);
873ef191 4091 nl = strchr(p, '\n');
3280af22 4092 nl = (nl) ? nl+1 : SvEND(PL_e_script);
7dfe3f66 4093 if (nl-p == 0) {
0cb96387 4094 filter_del(read_e_script);
873ef191 4095 return 0;
7dfe3f66 4096 }
873ef191 4097 sv_catpvn(buf_sv, p, nl-p);
3280af22 4098 sv_chop(PL_e_script, nl);
873ef191
GS		 4099 return 1;
4100}
Unnamed repository; edit this file 'description' to name the repository.