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