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