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