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