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