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