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