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