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