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
allow spaces in -I switch argument
[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) {
33f46ff6 122 INIT_THREADS;
1feb2720 123#ifdef USE_THREADS
d55594ae
GS		 124#ifdef ALLOC_THREAD_KEY
125 ALLOC_THREAD_KEY;
126#else
533c011a 127 if (pthread_key_create(&PL_thr_key, 0))
cea2e8a9 128 Perl_croak(aTHX_ "panic: pthread_key_create");
d55594ae 129#endif
533c011a 130 MUTEX_INIT(&PL_sv_mutex);
a863c7d1
MB		 131 /*
132 * Safe to use basic SV functions from now on (though
133 * not things like mortals or tainting yet).
134 */
533c011a
NIS		 135 MUTEX_INIT(&PL_eval_mutex);
136 COND_INIT(&PL_eval_cond);
137 MUTEX_INIT(&PL_threads_mutex);
138 COND_INIT(&PL_nthreads_cond);
dce16143 139#ifdef EMULATE_ATOMIC_REFCOUNTS
533c011a 140 MUTEX_INIT(&PL_svref_mutex);
dce16143 141#endif /* EMULATE_ATOMIC_REFCOUNTS */
a863c7d1 142
5ff3f7a4
GS		 143 MUTEX_INIT(&PL_cred_mutex);
144
199100c8 145 thr = init_main_thread();
11343788
MB		 146#endif /* USE_THREADS */
147
0b94c7bb 148 PL_protect = MEMBER_TO_FPTR(Perl_default_protect); /* for exceptions */
312caa8e 149
2aea9f8a
GS		 150 PL_curcop = &PL_compiling; /* needed by ckWARN, right away */
151
3280af22
NIS		 152 PL_linestr = NEWSV(65,79);
153 sv_upgrade(PL_linestr,SVt_PVIV);
79072805 154
3280af22 155 if (!SvREADONLY(&PL_sv_undef)) {
d689ffdd
JP		 156 /* set read-only and try to insure than we wont see REFCNT==0
157 very often */
158
3280af22
NIS		 159 SvREADONLY_on(&PL_sv_undef);
160 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
79072805 161
3280af22
NIS		 162 sv_setpv(&PL_sv_no,PL_No);
163 SvNV(&PL_sv_no);
164 SvREADONLY_on(&PL_sv_no);
165 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
79072805 166
3280af22
NIS		 167 sv_setpv(&PL_sv_yes,PL_Yes);
168 SvNV(&PL_sv_yes);
169 SvREADONLY_on(&PL_sv_yes);
170 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
6e72f9df 171 }
79072805 172
76e3520e
GS		 173#ifdef PERL_OBJECT
174 /* TODO: */
6b88bc9c 175 /* PL_sighandlerp = sighandler; */
76e3520e 176#else
cea2e8a9 177 PL_sighandlerp = Perl_sighandler;
76e3520e 178#endif
3280af22 179 PL_pidstatus = newHV();
44a8e56a 180
79072805
LW		 181#ifdef MSDOS
182 /*
183 * There is no way we can refer to them from Perl so close them to save
184 * space. The other alternative would be to provide STDAUX and STDPRN
185 * filehandles.
186 */
187 (void)fclose(stdaux);
188 (void)fclose(stdprn);
189#endif
190 }
191
79cb57f6 192 PL_nrs = newSVpvn("\n", 1);
3280af22 193 PL_rs = SvREFCNT_inc(PL_nrs);
dc92893f 194
cea2e8a9 195 init_stacks();
79072805 196
748a9306 197 init_ids();
3280af22 198 PL_lex_state = LEX_NOTPARSING;
a5f75d66 199
312caa8e 200 JMPENV_BOOTSTRAP;
f86702cc 201 STATUS_ALL_SUCCESS;
202
0672f40e 203 init_i18nl10n(1);
36477c24 204 SET_NUMERIC_STANDARD();
0b5b802d 205
cceca5ed
GS		 206#if defined(PERL_SUBVERSION) && PERL_SUBVERSION > 0
207 sprintf(PL_patchlevel, "%7.5f", (double) PERL_REVISION
208 + ((double) PERL_VERSION / (double) 1000)
209 + ((double) PERL_SUBVERSION / (double) 100000));
a5f75d66 210#else
cceca5ed
GS		 211 sprintf(PL_patchlevel, "%5.3f", (double) PERL_REVISION +
212 ((double) PERL_VERSION / (double) 1000));
a5f75d66 213#endif
79072805 214
ab821d7f 215#if defined(LOCAL_PATCH_COUNT)
3280af22 216 PL_localpatches = local_patches; /* For possible -v */
ab821d7f 217#endif
218
4b556e6c 219 PerlIO_init(); /* Hook to IO system */
760ac839 220
3280af22
NIS		 221 PL_fdpid = newAV(); /* for remembering popen pids by fd */
222 PL_modglobal = newHV(); /* pointers to per-interpreter module globals */
8990e307 223
8990e307 224 ENTER;
79072805
LW		 225}
226
227void
0cb96387 228perl_destruct(pTHXx)
79072805 229{
11343788 230 dTHR;
748a9306 231 int destruct_level; /* 0=none, 1=full, 2=full with checks */
8990e307 232 I32 last_sv_count;
a0d0e21e 233 HV *hv;
1f2bfc8a 234#ifdef USE_THREADS
33f46ff6 235 Thread t;
cea2e8a9 236 dTHX;
1f2bfc8a 237#endif /* USE_THREADS */
8990e307 238
7766f137
GS		 239 /* wait for all pseudo-forked children to finish */
240 PERL_WAIT_FOR_CHILDREN;
241
11343788 242#ifdef USE_THREADS
0f15f207 243#ifndef FAKE_THREADS
8023c3ce
MB		 244 /* Pass 1 on any remaining threads: detach joinables, join zombies */
245 retry_cleanup:
533c011a 246 MUTEX_LOCK(&PL_threads_mutex);
bf49b057 247 DEBUG_S(PerlIO_printf(Perl_debug_log,
c7848ba1 248 "perl_destruct: waiting for %d threads...\n",
533c011a 249 PL_nthreads - 1));
33f46ff6 250 for (t = thr->next; t != thr; t = t->next) {
605e5515
MB		 251 MUTEX_LOCK(&t->mutex);
252 switch (ThrSTATE(t)) {
253 AV *av;
c7848ba1 254 case THRf_ZOMBIE:
bf49b057 255 DEBUG_S(PerlIO_printf(Perl_debug_log,
c7848ba1 256 "perl_destruct: joining zombie %p\n", t));
605e5515
MB		 257 ThrSETSTATE(t, THRf_DEAD);
258 MUTEX_UNLOCK(&t->mutex);
533c011a 259 PL_nthreads--;
8023c3ce
MB		 260 /*
261 * The SvREFCNT_dec below may take a long time (e.g. av
262 * may contain an object scalar whose destructor gets
263 * called) so we have to unlock threads_mutex and start
264 * all over again.
265 */
533c011a 266 MUTEX_UNLOCK(&PL_threads_mutex);
ea0efc06 267 JOIN(t, &av);
605e5515 268 SvREFCNT_dec((SV*)av);
bf49b057 269 DEBUG_S(PerlIO_printf(Perl_debug_log,
c7848ba1 270 "perl_destruct: joined zombie %p OK\n", t));
8023c3ce 271 goto retry_cleanup;
c7848ba1 272 case THRf_R_JOINABLE:
bf49b057 273 DEBUG_S(PerlIO_printf(Perl_debug_log,
c7848ba1
MB		 274 "perl_destruct: detaching thread %p\n", t));
275 ThrSETSTATE(t, THRf_R_DETACHED);
276 /*
277 * We unlock threads_mutex and t->mutex in the opposite order
278 * from which we locked them just so that DETACH won't
279 * deadlock if it panics. It's only a breach of good style
280 * not a bug since they are unlocks not locks.
281 */
533c011a 282 MUTEX_UNLOCK(&PL_threads_mutex);
c7848ba1
MB		 283 DETACH(t);
284 MUTEX_UNLOCK(&t->mutex);
8023c3ce 285 goto retry_cleanup;
c7848ba1 286 default:
bf49b057 287 DEBUG_S(PerlIO_printf(Perl_debug_log,
c7848ba1
MB		 288 "perl_destruct: ignoring %p (state %u)\n",
289 t, ThrSTATE(t)));
290 MUTEX_UNLOCK(&t->mutex);
c7848ba1 291 /* fall through and out */
33f46ff6
MB		 292 }
293 }
8023c3ce
MB		 294 /* We leave the above "Pass 1" loop with threads_mutex still locked */
295
296 /* Pass 2 on remaining threads: wait for the thread count to drop to one */
533c011a 297 while (PL_nthreads > 1)
11343788 298 {
bf49b057 299 DEBUG_S(PerlIO_printf(Perl_debug_log,
c7848ba1 300 "perl_destruct: final wait for %d threads\n",
533c011a
NIS		 301 PL_nthreads - 1));
302 COND_WAIT(&PL_nthreads_cond, &PL_threads_mutex);
11343788
MB		 303 }
304 /* At this point, we're the last thread */
533c011a 305 MUTEX_UNLOCK(&PL_threads_mutex);
bf49b057 306 DEBUG_S(PerlIO_printf(Perl_debug_log, "perl_destruct: armageddon has arrived\n"));
533c011a
NIS		 307 MUTEX_DESTROY(&PL_threads_mutex);
308 COND_DESTROY(&PL_nthreads_cond);
0f15f207 309#endif /* !defined(FAKE_THREADS) */
11343788
MB		 310#endif /* USE_THREADS */
311
3280af22 312 destruct_level = PL_perl_destruct_level;
4633a7c4
LW		 313#ifdef DEBUGGING
314 {
315 char *s;
76e3520e 316 if (s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL")) {
5f05dabc 317 int i = atoi(s);
318 if (destruct_level < i)
319 destruct_level = i;
320 }
4633a7c4
LW		 321 }
322#endif
323
8990e307 324 LEAVE;
a0d0e21e
LW		 325 FREETMPS;
326
ff0cee69 327 /* We must account for everything. */
328
329 /* Destroy the main CV and syntax tree */
3280af22
NIS		 330 if (PL_main_root) {
331 PL_curpad = AvARRAY(PL_comppad);
332 op_free(PL_main_root);
333 PL_main_root = Nullop;
a0d0e21e 334 }
3280af22
NIS		 335 PL_curcop = &PL_compiling;
336 PL_main_start = Nullop;
337 SvREFCNT_dec(PL_main_cv);
338 PL_main_cv = Nullcv;
24d3c518 339 PL_dirty = TRUE;
ff0cee69 340
3280af22 341 if (PL_sv_objcount) {
a0d0e21e
LW		 342 /*
343 * Try to destruct global references. We do this first so that the
344 * destructors and destructees still exist. Some sv's might remain.
345 * Non-referenced objects are on their own.
346 */
a0d0e21e 347 sv_clean_objs();
8990e307
LW		 348 }
349
5cd24f17 350 /* unhook hooks which will soon be, or use, destroyed data */
3280af22
NIS		 351 SvREFCNT_dec(PL_warnhook);
352 PL_warnhook = Nullsv;
353 SvREFCNT_dec(PL_diehook);
354 PL_diehook = Nullsv;
5cd24f17 355
4b556e6c 356 /* call exit list functions */
3280af22 357 while (PL_exitlistlen-- > 0)
0cb96387 358 PL_exitlist[PL_exitlistlen].fn(aTHXo_ PL_exitlist[PL_exitlistlen].ptr);
4b556e6c 359
3280af22 360 Safefree(PL_exitlist);
4b556e6c 361
a0d0e21e 362 if (destruct_level == 0){
8990e307 363
a0d0e21e
LW		 364 DEBUG_P(debprofdump());
365
366 /* The exit() function will do everything that needs doing. */
367 return;
368 }
5dd60ef7 369
5f05dabc 370 /* loosen bonds of global variables */
371
3280af22
NIS		 372 if(PL_rsfp) {
373 (void)PerlIO_close(PL_rsfp);
374 PL_rsfp = Nullfp;
8ebc5c01 375 }
376
377 /* Filters for program text */
3280af22
NIS		 378 SvREFCNT_dec(PL_rsfp_filters);
379 PL_rsfp_filters = Nullav;
8ebc5c01 380
381 /* switches */
3280af22
NIS		 382 PL_preprocess = FALSE;
383 PL_minus_n = FALSE;
384 PL_minus_p = FALSE;
385 PL_minus_l = FALSE;
386 PL_minus_a = FALSE;
387 PL_minus_F = FALSE;
388 PL_doswitches = FALSE;
599cee73 389 PL_dowarn = G_WARN_OFF;
3280af22
NIS		 390 PL_doextract = FALSE;
391 PL_sawampersand = FALSE; /* must save all match strings */
3280af22
NIS		 392 PL_unsafe = FALSE;
393
394 Safefree(PL_inplace);
395 PL_inplace = Nullch;
396
397 if (PL_e_script) {
398 SvREFCNT_dec(PL_e_script);
399 PL_e_script = Nullsv;
8ebc5c01 400 }
401
402 /* magical thingies */
403
3280af22
NIS		 404 Safefree(PL_ofs); /* $, */
405 PL_ofs = Nullch;
5f05dabc 406
3280af22
NIS		 407 Safefree(PL_ors); /* $\ */
408 PL_ors = Nullch;
8ebc5c01 409
3280af22
NIS		 410 SvREFCNT_dec(PL_rs); /* $/ */
411 PL_rs = Nullsv;
dc92893f 412
3280af22
NIS		 413 SvREFCNT_dec(PL_nrs); /* $/ helper */
414 PL_nrs = Nullsv;
5f05dabc 415
3280af22 416 PL_multiline = 0; /* $* */
5f05dabc 417
3280af22
NIS		 418 SvREFCNT_dec(PL_statname);
419 PL_statname = Nullsv;
420 PL_statgv = Nullgv;
5f05dabc 421
8ebc5c01 422 /* defgv, aka *_ should be taken care of elsewhere */
423
8ebc5c01 424 /* clean up after study() */
3280af22
NIS		 425 SvREFCNT_dec(PL_lastscream);
426 PL_lastscream = Nullsv;
427 Safefree(PL_screamfirst);
428 PL_screamfirst = 0;
429 Safefree(PL_screamnext);
430 PL_screamnext = 0;
8ebc5c01 431
7d5ea4e7
GS		 432 /* float buffer */
433 Safefree(PL_efloatbuf);
434 PL_efloatbuf = Nullch;
435 PL_efloatsize = 0;
436
8ebc5c01 437 /* startup and shutdown function lists */
3280af22
NIS		 438 SvREFCNT_dec(PL_beginav);
439 SvREFCNT_dec(PL_endav);
4f25aa18 440 SvREFCNT_dec(PL_stopav);
3280af22
NIS		 441 SvREFCNT_dec(PL_initav);
442 PL_beginav = Nullav;
443 PL_endav = Nullav;
4f25aa18 444 PL_stopav = Nullav;
3280af22 445 PL_initav = Nullav;
5618dfe8 446
8ebc5c01 447 /* shortcuts just get cleared */
3280af22 448 PL_envgv = Nullgv;
3280af22
NIS		 449 PL_incgv = Nullgv;
450 PL_hintgv = Nullgv;
451 PL_errgv = Nullgv;
452 PL_argvgv = Nullgv;
453 PL_argvoutgv = Nullgv;
454 PL_stdingv = Nullgv;
bf49b057 455 PL_stderrgv = Nullgv;
3280af22
NIS		 456 PL_last_in_gv = Nullgv;
457 PL_replgv = Nullgv;
5c831c24 458 PL_debstash = Nullhv;
8ebc5c01 459
460 /* reset so print() ends up where we expect */
461 setdefout(Nullgv);
5c831c24 462
7a1c5554
GS		 463 SvREFCNT_dec(PL_argvout_stack);
464 PL_argvout_stack = Nullav;
8ebc5c01 465
5c831c24
GS		 466 SvREFCNT_dec(PL_fdpid);
467 PL_fdpid = Nullav;
468 SvREFCNT_dec(PL_modglobal);
469 PL_modglobal = Nullhv;
470 SvREFCNT_dec(PL_preambleav);
471 PL_preambleav = Nullav;
472 SvREFCNT_dec(PL_subname);
473 PL_subname = Nullsv;
474 SvREFCNT_dec(PL_linestr);
475 PL_linestr = Nullsv;
476 SvREFCNT_dec(PL_pidstatus);
477 PL_pidstatus = Nullhv;
478 SvREFCNT_dec(PL_toptarget);
479 PL_toptarget = Nullsv;
480 SvREFCNT_dec(PL_bodytarget);
481 PL_bodytarget = Nullsv;
482 PL_formtarget = Nullsv;
483
484 /* clear utf8 character classes */
485 SvREFCNT_dec(PL_utf8_alnum);
486 SvREFCNT_dec(PL_utf8_alnumc);
487 SvREFCNT_dec(PL_utf8_ascii);
488 SvREFCNT_dec(PL_utf8_alpha);
489 SvREFCNT_dec(PL_utf8_space);
490 SvREFCNT_dec(PL_utf8_cntrl);
491 SvREFCNT_dec(PL_utf8_graph);
492 SvREFCNT_dec(PL_utf8_digit);
493 SvREFCNT_dec(PL_utf8_upper);
494 SvREFCNT_dec(PL_utf8_lower);
495 SvREFCNT_dec(PL_utf8_print);
496 SvREFCNT_dec(PL_utf8_punct);
497 SvREFCNT_dec(PL_utf8_xdigit);
498 SvREFCNT_dec(PL_utf8_mark);
499 SvREFCNT_dec(PL_utf8_toupper);
500 SvREFCNT_dec(PL_utf8_tolower);
501 PL_utf8_alnum = Nullsv;
502 PL_utf8_alnumc = Nullsv;
503 PL_utf8_ascii = Nullsv;
504 PL_utf8_alpha = Nullsv;
505 PL_utf8_space = Nullsv;
506 PL_utf8_cntrl = Nullsv;
507 PL_utf8_graph = Nullsv;
508 PL_utf8_digit = Nullsv;
509 PL_utf8_upper = Nullsv;
510 PL_utf8_lower = Nullsv;
511 PL_utf8_print = Nullsv;
512 PL_utf8_punct = Nullsv;
513 PL_utf8_xdigit = Nullsv;
514 PL_utf8_mark = Nullsv;
515 PL_utf8_toupper = Nullsv;
516 PL_utf8_totitle = Nullsv;
517 PL_utf8_tolower = Nullsv;
518
971a9dd3
GS		 519 if (!specialWARN(PL_compiling.cop_warnings))
520 SvREFCNT_dec(PL_compiling.cop_warnings);
5c831c24
GS		 521 PL_compiling.cop_warnings = Nullsv;
522
a0d0e21e 523 /* Prepare to destruct main symbol table. */
5f05dabc 524
3280af22
NIS		 525 hv = PL_defstash;
526 PL_defstash = 0;
a0d0e21e 527 SvREFCNT_dec(hv);
5c831c24
GS		 528 SvREFCNT_dec(PL_curstname);
529 PL_curstname = Nullsv;
a0d0e21e 530
5a844595
GS		 531 /* clear queued errors */
532 SvREFCNT_dec(PL_errors);
533 PL_errors = Nullsv;
534
a0d0e21e 535 FREETMPS;
0453d815 536 if (destruct_level >= 2 && ckWARN_d(WARN_INTERNAL)) {
3280af22 537 if (PL_scopestack_ix != 0)
0453d815
PM		 538 Perl_warner(aTHX_ WARN_INTERNAL,
539 "Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
3280af22
NIS		 540 (long)PL_scopestack_ix);
541 if (PL_savestack_ix != 0)
0453d815
PM		 542 Perl_warner(aTHX_ WARN_INTERNAL,
543 "Unbalanced saves: %ld more saves than restores\n",
3280af22
NIS		 544 (long)PL_savestack_ix);
545 if (PL_tmps_floor != -1)
0453d815 546 Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced tmps: %ld more allocs than frees\n",
3280af22 547 (long)PL_tmps_floor + 1);
a0d0e21e 548 if (cxstack_ix != -1)
0453d815 549 Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced context: %ld more PUSHes than POPs\n",
ff0cee69 550 (long)cxstack_ix + 1);
a0d0e21e 551 }
8990e307
LW		 552
553 /* Now absolutely destruct everything, somehow or other, loops or no. */
8990e307 554 last_sv_count = 0;
3280af22
NIS		 555 SvFLAGS(PL_strtab) |= SVTYPEMASK; /* don't clean out strtab now */
556 while (PL_sv_count != 0 && PL_sv_count != last_sv_count) {
557 last_sv_count = PL_sv_count;
8990e307
LW		 558 sv_clean_all();
559 }
3280af22
NIS		 560 SvFLAGS(PL_strtab) &= ~SVTYPEMASK;
561 SvFLAGS(PL_strtab) |= SVt_PVHV;
6e72f9df 562
563 /* Destruct the global string table. */
564 {
565 /* Yell and reset the HeVAL() slots that are still holding refcounts,
566 * so that sv_free() won't fail on them.
567 */
568 I32 riter;
569 I32 max;
570 HE *hent;
571 HE **array;
572
573 riter = 0;
3280af22
NIS		 574 max = HvMAX(PL_strtab);
575 array = HvARRAY(PL_strtab);
6e72f9df 576 hent = array[0];
577 for (;;) {
0453d815
PM		 578 if (hent && ckWARN_d(WARN_INTERNAL)) {
579 Perl_warner(aTHX_ WARN_INTERNAL,
580 "Unbalanced string table refcount: (%d) for \"%s\"",
6e72f9df 581 HeVAL(hent) - Nullsv, HeKEY(hent));
582 HeVAL(hent) = Nullsv;
583 hent = HeNEXT(hent);
584 }
585 if (!hent) {
586 if (++riter > max)
587 break;
588 hent = array[riter];
589 }
590 }
591 }
3280af22 592 SvREFCNT_dec(PL_strtab);
6e72f9df 593
0453d815
PM		 594 if (PL_sv_count != 0 && ckWARN_d(WARN_INTERNAL))
595 Perl_warner(aTHX_ WARN_INTERNAL,"Scalars leaked: %ld\n", (long)PL_sv_count);
6e72f9df 596
4633a7c4 597 sv_free_arenas();
44a8e56a 598
599 /* No SVs have survived, need to clean out */
3280af22
NIS		 600 Safefree(PL_origfilename);
601 Safefree(PL_archpat_auto);
602 Safefree(PL_reg_start_tmp);
5c5e4c24
IZ		 603 if (PL_reg_curpm)
604 Safefree(PL_reg_curpm);
82ba1be6 605 Safefree(PL_reg_poscache);
3280af22
NIS		 606 Safefree(HeKEY_hek(&PL_hv_fetch_ent_mh));
607 Safefree(PL_op_mask);
6e72f9df 608 nuke_stacks();
3280af22 609 PL_hints = 0; /* Reset hints. Should hints be per-interpreter ? */
a0d0e21e
LW		 610
611 DEBUG_P(debprofdump());
11343788 612#ifdef USE_THREADS
5f08fbcd 613 MUTEX_DESTROY(&PL_strtab_mutex);
533c011a
NIS		 614 MUTEX_DESTROY(&PL_sv_mutex);
615 MUTEX_DESTROY(&PL_eval_mutex);
5ff3f7a4 616 MUTEX_DESTROY(&PL_cred_mutex);
533c011a 617 COND_DESTROY(&PL_eval_cond);
11d617a5
GS		 618#ifdef EMULATE_ATOMIC_REFCOUNTS
619 MUTEX_DESTROY(&PL_svref_mutex);
620#endif /* EMULATE_ATOMIC_REFCOUNTS */
fc36a67e 621
8023c3ce 622 /* As the penultimate thing, free the non-arena SV for thrsv */
533c011a
NIS		 623 Safefree(SvPVX(PL_thrsv));
624 Safefree(SvANY(PL_thrsv));
625 Safefree(PL_thrsv);
626 PL_thrsv = Nullsv;
8023c3ce
MB		 627#endif /* USE_THREADS */
628
fc36a67e 629 /* As the absolutely last thing, free the non-arena SV for mess() */
630
3280af22 631 if (PL_mess_sv) {
9c63abab
GS		 632 /* it could have accumulated taint magic */
633 if (SvTYPE(PL_mess_sv) >= SVt_PVMG) {
634 MAGIC* mg;
635 MAGIC* moremagic;
636 for (mg = SvMAGIC(PL_mess_sv); mg; mg = moremagic) {
637 moremagic = mg->mg_moremagic;
638 if (mg->mg_ptr && mg->mg_type != 'g' && mg->mg_len >= 0)
639 Safefree(mg->mg_ptr);
640 Safefree(mg);
641 }
642 }
fc36a67e 643 /* we know that type >= SVt_PV */
3280af22
NIS		 644 SvOOK_off(PL_mess_sv);
645 Safefree(SvPVX(PL_mess_sv));
646 Safefree(SvANY(PL_mess_sv));
647 Safefree(PL_mess_sv);
648 PL_mess_sv = Nullsv;
fc36a67e 649 }
79072805
LW		 650}
651
652void
0cb96387 653perl_free(pTHXx)
79072805 654{
c5be433b 655#if defined(PERL_OBJECT)
7f0d82f7 656 PerlMem_free(this);
76e3520e 657#else
7f0d82f7 658 PerlMem_free(aTHXx);
76e3520e 659#endif
79072805
LW		 660}
661
4b556e6c 662void
864dbfa3 663Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr)
4b556e6c 664{
3280af22
NIS		 665 Renew(PL_exitlist, PL_exitlistlen+1, PerlExitListEntry);
666 PL_exitlist[PL_exitlistlen].fn = fn;
667 PL_exitlist[PL_exitlistlen].ptr = ptr;
668 ++PL_exitlistlen;
4b556e6c
JD		 669}
670
79072805 671int
0cb96387 672perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env)
8d063cd8 673{
11343788 674 dTHR;
6224f72b 675 I32 oldscope;
6224f72b 676 int ret;
db36c5a1 677 dJMPENV;
cea2e8a9
GS		 678#ifdef USE_THREADS
679 dTHX;
680#endif
8d063cd8 681
a687059c
LW		 682#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
683#ifdef IAMSUID
684#undef IAMSUID
cea2e8a9 685 Perl_croak(aTHX_ "suidperl is no longer needed since the kernel can now execute\n\
a687059c
LW		 686setuid perl scripts securely.\n");
687#endif
688#endif
689
8f1f23e8 690#if defined(__DYNAMIC__) && (defined(NeXT) || defined(__NeXT__))
6e72f9df 691 _dyld_lookup_and_bind
692 ("__environ", (unsigned long *) &environ_pointer, NULL);
693#endif /* environ */
694
3280af22
NIS		 695 PL_origargv = argv;
696 PL_origargc = argc;
a0d0e21e 697#ifndef VMS /* VMS doesn't have environ array */
3280af22 698 PL_origenviron = environ;
a0d0e21e
LW		 699#endif
700
3280af22 701 if (PL_do_undump) {
a0d0e21e
LW		 702
703 /* Come here if running an undumped a.out. */
704
3280af22
NIS		 705 PL_origfilename = savepv(argv[0]);
706 PL_do_undump = FALSE;
a0d0e21e 707 cxstack_ix = -1; /* start label stack again */
748a9306 708 init_ids();
a0d0e21e
LW		 709 init_postdump_symbols(argc,argv,env);
710 return 0;
711 }
712
3280af22
NIS		 713 if (PL_main_root) {
714 PL_curpad = AvARRAY(PL_comppad);
715 op_free(PL_main_root);
716 PL_main_root = Nullop;
ff0cee69 717 }
3280af22
NIS		 718 PL_main_start = Nullop;
719 SvREFCNT_dec(PL_main_cv);
720 PL_main_cv = Nullcv;
79072805 721
3280af22
NIS		 722 time(&PL_basetime);
723 oldscope = PL_scopestack_ix;
599cee73 724 PL_dowarn = G_WARN_OFF;
f86702cc 725
db36c5a1
GS		 726 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_parse_body),
727 env, xsinit);
6224f72b 728 switch (ret) {
312caa8e 729 case 0:
4f25aa18
GS		 730 if (PL_stopav)
731 call_list(oldscope, PL_stopav);
312caa8e 732 return 0;
6224f72b
GS		 733 case 1:
734 STATUS_ALL_FAILURE;
735 /* FALL THROUGH */
736 case 2:
737 /* my_exit() was called */
3280af22 738 while (PL_scopestack_ix > oldscope)
6224f72b
GS		 739 LEAVE;
740 FREETMPS;
3280af22 741 PL_curstash = PL_defstash;
4f25aa18
GS		 742 if (PL_stopav)
743 call_list(oldscope, PL_stopav);
6224f72b
GS		 744 return STATUS_NATIVE_EXPORT;
745 case 3:
bf49b057 746 PerlIO_printf(Perl_error_log, "panic: top_env\n");
6224f72b
GS		 747 return 1;
748 }
a6c40364 749 return 0;
312caa8e
CS		 750}
751
752STATIC void *
cea2e8a9 753S_parse_body(pTHX_ va_list args)
312caa8e
CS		 754{
755 dTHR;
756 int argc = PL_origargc;
757 char **argv = PL_origargv;
758 char **env = va_arg(args, char**);
759 char *scriptname = NULL;
760 int fdscript = -1;
761 VOL bool dosearch = FALSE;
762 char *validarg = "";
763 AV* comppadlist;
764 register SV *sv;
765 register char *s;
f4c556ac 766 char *cddir = Nullch;
312caa8e 767
864dbfa3 768 XSINIT_t xsinit = va_arg(args, XSINIT_t);
79072805 769
3280af22 770 sv_setpvn(PL_linestr,"",0);
79cb57f6 771 sv = newSVpvn("",0); /* first used for -I flags */
6224f72b
GS		 772 SAVEFREESV(sv);
773 init_main_stash();
54310121 774
6224f72b
GS		 775 for (argc--,argv++; argc > 0; argc--,argv++) {
776 if (argv[0][0] != '-' || !argv[0][1])
777 break;
778#ifdef DOSUID
779 if (*validarg)
780 validarg = " PHOOEY ";
781 else
782 validarg = argv[0];
13281fa4 783#endif
6224f72b
GS		 784 s = argv[0]+1;
785 reswitch:
786 switch (*s) {
1d5472a9
GS		 787#ifndef PERL_STRICT_CR
788 case '\r':
789#endif
6224f72b
GS		 790 case ' ':
791 case '0':
792 case 'F':
793 case 'a':
794 case 'c':
795 case 'd':
796 case 'D':
797 case 'h':
798 case 'i':
799 case 'l':
800 case 'M':
801 case 'm':
802 case 'n':
803 case 'p':
804 case 's':
805 case 'u':
806 case 'U':
807 case 'v':
599cee73
PM		 808 case 'W':
809 case 'X':
6224f72b
GS		 810 case 'w':
811 if (s = moreswitches(s))
812 goto reswitch;
813 break;
33b78306 814
6224f72b 815 case 'T':
3280af22 816 PL_tainting = TRUE;
6224f72b
GS		 817 s++;
818 goto reswitch;
f86702cc 819
6224f72b 820 case 'e':
3280af22 821 if (PL_euid != PL_uid || PL_egid != PL_gid)
cea2e8a9 822 Perl_croak(aTHX_ "No -e allowed in setuid scripts");
3280af22 823 if (!PL_e_script) {
79cb57f6 824 PL_e_script = newSVpvn("",0);
0cb96387 825 filter_add(read_e_script, NULL);
6224f72b
GS		 826 }
827 if (*++s)
3280af22 828 sv_catpv(PL_e_script, s);
6224f72b 829 else if (argv[1]) {
3280af22 830 sv_catpv(PL_e_script, argv[1]);
6224f72b
GS		 831 argc--,argv++;
832 }
833 else
cea2e8a9 834 Perl_croak(aTHX_ "No code specified for -e");
3280af22 835 sv_catpv(PL_e_script, "\n");
6224f72b 836 break;
afe37c7d 837
6224f72b
GS		 838 case 'I': /* -I handled both here and in moreswitches() */
839 forbid_setid("-I");
840 if (!*++s && (s=argv[1]) != Nullch) {
841 argc--,argv++;
842 }
6224f72b 843 if (s && *s) {
0df16ed7
GS		 844 char *p;
845 STRLEN len = strlen(s);
846 p = savepvn(s, len);
6224f72b 847 incpush(p, TRUE);
0df16ed7
GS		 848 sv_catpvn(sv, "-I", 2);
849 sv_catpvn(sv, p, len);
850 sv_catpvn(sv, " ", 1);
6224f72b 851 Safefree(p);
0df16ed7
GS		 852 }
853 else
854 Perl_croak(aTHX_ "No argument specified for -I");
6224f72b
GS		 855 break;
856 case 'P':
857 forbid_setid("-P");
3280af22 858 PL_preprocess = TRUE;
6224f72b
GS		 859 s++;
860 goto reswitch;
861 case 'S':
862 forbid_setid("-S");
863 dosearch = TRUE;
864 s++;
865 goto reswitch;
866 case 'V':
3280af22
NIS		 867 if (!PL_preambleav)
868 PL_preambleav = newAV();
869 av_push(PL_preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
6224f72b 870 if (*++s != ':') {
3280af22 871 PL_Sv = newSVpv("print myconfig();",0);
6224f72b 872#ifdef VMS
6b88bc9c 873 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
6224f72b 874#else
3280af22 875 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
6224f72b 876#endif
3280af22 877 sv_catpv(PL_Sv,"\" Compile-time options:");
6224f72b 878# ifdef DEBUGGING
3280af22 879 sv_catpv(PL_Sv," DEBUGGING");
6224f72b 880# endif
6224f72b 881# ifdef MULTIPLICITY
8f872242 882 sv_catpv(PL_Sv," MULTIPLICITY");
6224f72b 883# endif
b363f7ed
GS		 884# ifdef USE_THREADS
885 sv_catpv(PL_Sv," USE_THREADS");
886# endif
887# ifdef PERL_OBJECT
888 sv_catpv(PL_Sv," PERL_OBJECT");
889# endif
890# ifdef PERL_IMPLICIT_CONTEXT
891 sv_catpv(PL_Sv," PERL_IMPLICIT_CONTEXT");
892# endif
893# ifdef PERL_IMPLICIT_SYS
894 sv_catpv(PL_Sv," PERL_IMPLICIT_SYS");
895# endif
3280af22 896 sv_catpv(PL_Sv,"\\n\",");
b363f7ed 897
6224f72b
GS		 898#if defined(LOCAL_PATCH_COUNT)
899 if (LOCAL_PATCH_COUNT > 0) {
900 int i;
3280af22 901 sv_catpv(PL_Sv,"\" Locally applied patches:\\n\",");
6224f72b 902 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
3280af22 903 if (PL_localpatches[i])
cea2e8a9 904 Perl_sv_catpvf(aTHX_ PL_Sv,"q\" \t%s\n\",",PL_localpatches[i]);
6224f72b
GS		 905 }
906 }
907#endif
cea2e8a9 908 Perl_sv_catpvf(aTHX_ PL_Sv,"\" Built under %s\\n\"",OSNAME);
6224f72b
GS		 909#ifdef __DATE__
910# ifdef __TIME__
cea2e8a9 911 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
6224f72b 912# else
cea2e8a9 913 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled on %s\\n\"",__DATE__);
6224f72b
GS		 914# endif
915#endif
3280af22 916 sv_catpv(PL_Sv, "; \
6224f72b
GS		 917$\"=\"\\n \"; \
918@env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; \
919print \" \\%ENV:\\n @env\\n\" if @env; \
920print \" \\@INC:\\n @INC\\n\";");
921 }
922 else {
3280af22
NIS		 923 PL_Sv = newSVpv("config_vars(qw(",0);
924 sv_catpv(PL_Sv, ++s);
925 sv_catpv(PL_Sv, "))");
6224f72b
GS		 926 s += strlen(s);
927 }
3280af22 928 av_push(PL_preambleav, PL_Sv);
6224f72b
GS		 929 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
930 goto reswitch;
931 case 'x':
3280af22 932 PL_doextract = TRUE;
6224f72b
GS		 933 s++;
934 if (*s)
f4c556ac 935 cddir = s;
6224f72b
GS		 936 break;
937 case 0:
938 break;
939 case '-':
940 if (!*++s || isSPACE(*s)) {
941 argc--,argv++;
942 goto switch_end;
943 }
944 /* catch use of gnu style long options */
945 if (strEQ(s, "version")) {
946 s = "v";
947 goto reswitch;
948 }
949 if (strEQ(s, "help")) {
950 s = "h";
951 goto reswitch;
952 }
953 s--;
954 /* FALL THROUGH */
955 default:
cea2e8a9 956 Perl_croak(aTHX_ "Unrecognized switch: -%s (-h will show valid options)",s);
8d063cd8
LW		 957 }
958 }
6224f72b 959 switch_end:
54310121 960
f675dbe5
CB		 961 if (
962#ifndef SECURE_INTERNAL_GETENV
963 !PL_tainting &&
964#endif
0df16ed7
GS		 965 (s = PerlEnv_getenv("PERL5OPT")))
966 {
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;
0df16ed7
GS		 1750 p = s;
1751 /* ignore trailing spaces (possibly followed by other switches) */
1752 do {
1753 for (e = p; *e && !isSPACE(*e); e++) ;
1754 p = e;
1755 while (isSPACE(*p))
1756 p++;
1757 } while (*p && *p != '-');
1758 e = savepvn(s, e-s);
1759 incpush(e, TRUE);
1760 Safefree(e);
1761 s = p;
1762 if (*s == '-')
1763 s++;
79072805
LW		 1764 }
1765 else
0df16ed7 1766 Perl_croak(aTHX_ "No argument specified for -I");
fb73857a 1767 return s;
79072805 1768 case 'l':
3280af22 1769 PL_minus_l = TRUE;
79072805 1770 s++;
3280af22
NIS		 1771 if (PL_ors)
1772 Safefree(PL_ors);
79072805 1773 if (isDIGIT(*s)) {
3280af22
NIS		 1774 PL_ors = savepv("\n");
1775 PL_orslen = 1;
dff6d3cd 1776 *PL_ors = (char)scan_oct(s, 3 + (*s == '0'), &numlen);
79072805
LW		 1777 s += numlen;
1778 }
1779 else {
a863c7d1 1780 dTHR;
3280af22
NIS		 1781 if (RsPARA(PL_nrs)) {
1782 PL_ors = "\n\n";
1783 PL_orslen = 2;
c07a80fd 1784 }
1785 else
3280af22
NIS		 1786 PL_ors = SvPV(PL_nrs, PL_orslen);
1787 PL_ors = savepvn(PL_ors, PL_orslen);
79072805
LW		 1788 }
1789 return s;
1a30305b 1790 case 'M':
bbce6d69 1791 forbid_setid("-M"); /* XXX ? */
1a30305b 1792 /* FALL THROUGH */
1793 case 'm':
bbce6d69 1794 forbid_setid("-m"); /* XXX ? */
1a30305b 1795 if (*++s) {
a5f75d66 1796 char *start;
11343788 1797 SV *sv;
a5f75d66
AD		 1798 char *use = "use ";
1799 /* -M-foo == 'no foo' */
1800 if (*s == '-') { use = "no "; ++s; }
11343788 1801 sv = newSVpv(use,0);
a5f75d66 1802 start = s;
1a30305b 1803 /* We allow -M'Module qw(Foo Bar)' */
c07a80fd 1804 while(isALNUM(*s) || *s==':') ++s;
1805 if (*s != '=') {
11343788 1806 sv_catpv(sv, start);
c07a80fd 1807 if (*(start-1) == 'm') {
1808 if (*s != '\0')
cea2e8a9 1809 Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
11343788 1810 sv_catpv( sv, " ()");
c07a80fd 1811 }
1812 } else {
11343788
MB		 1813 sv_catpvn(sv, start, s-start);
1814 sv_catpv(sv, " split(/,/,q{");
1815 sv_catpv(sv, ++s);
1816 sv_catpv(sv, "})");
c07a80fd 1817 }
1a30305b 1818 s += strlen(s);
5c831c24 1819 if (!PL_preambleav)
3280af22
NIS		 1820 PL_preambleav = newAV();
1821 av_push(PL_preambleav, sv);
1a30305b 1822 }
1823 else
cea2e8a9 1824 Perl_croak(aTHX_ "No space allowed after -%c", *(s-1));
1a30305b 1825 return s;
79072805 1826 case 'n':
3280af22 1827 PL_minus_n = TRUE;
79072805
LW		 1828 s++;
1829 return s;
1830 case 'p':
3280af22 1831 PL_minus_p = TRUE;
79072805
LW		 1832 s++;
1833 return s;
1834 case 's':
bbce6d69 1835 forbid_setid("-s");
3280af22 1836 PL_doswitches = TRUE;
79072805
LW		 1837 s++;
1838 return s;
463ee0b2 1839 case 'T':
3280af22 1840 if (!PL_tainting)
cea2e8a9 1841 Perl_croak(aTHX_ "Too late for \"-T\" option");
463ee0b2
LW		 1842 s++;
1843 return s;
79072805 1844 case 'u':
3280af22 1845 PL_do_undump = TRUE;
79072805
LW		 1846 s++;
1847 return s;
1848 case 'U':
3280af22 1849 PL_unsafe = TRUE;
79072805
LW		 1850 s++;
1851 return s;
1852 case 'v':
cceca5ed
GS		 1853#if defined(PERL_SUBVERSION) && PERL_SUBVERSION > 0
1854 printf("\nThis is perl, version %d.%03d_%02d built for %s",
1855 PERL_REVISION, PERL_VERSION, PERL_SUBVERSION, ARCHNAME);
a5f75d66 1856#else
fb73857a 1857 printf("\nThis is perl, version %s built for %s",
6b88bc9c 1858 PL_patchlevel, ARCHNAME);
fb73857a 1859#endif
1860#if defined(LOCAL_PATCH_COUNT)
1861 if (LOCAL_PATCH_COUNT > 0)
1862 printf("\n(with %d registered patch%s, see perl -V for more detail)",
b900a521 1863 (int)LOCAL_PATCH_COUNT, (LOCAL_PATCH_COUNT!=1) ? "es" : "");
a5f75d66 1864#endif
1a30305b 1865
4eb8286e 1866 printf("\n\nCopyright 1987-1999, Larry Wall\n");
79072805 1867#ifdef MSDOS
fb73857a 1868 printf("\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
55497cff 1869#endif
1870#ifdef DJGPP
1871 printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
4eb8286e 1872 printf("djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
4633a7c4 1873#endif
79072805 1874#ifdef OS2
5dd60ef7 1875 printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
4eb8286e 1876 "Version 5 port Copyright (c) 1994-1999, Andreas Kaiser, Ilya Zakharevich\n");
79072805 1877#endif
79072805 1878#ifdef atarist
760ac839 1879 printf("atariST series port, ++jrb bammi@cadence.com\n");
79072805 1880#endif
a3f9223b 1881#ifdef __BEOS__
4eb8286e 1882 printf("BeOS port Copyright Tom Spindler, 1997-1999\n");
a3f9223b 1883#endif
1d84e8df 1884#ifdef MPE
4eb8286e 1885 printf("MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-1999\n");
1d84e8df 1886#endif
9d116dd7 1887#ifdef OEMVS
4eb8286e 1888 printf("MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
9d116dd7 1889#endif
495c5fdc 1890#ifdef __VOS__
4eb8286e 1891 printf("Stratus VOS port by Paul_Green@stratus.com, 1997-1999\n");
495c5fdc 1892#endif
092bebab 1893#ifdef __OPEN_VM
4eb8286e 1894 printf("VM/ESA port by Neale Ferguson, 1998-1999\n");
092bebab 1895#endif
a1a0e61e 1896#ifdef POSIX_BC
4eb8286e 1897 printf("BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
a1a0e61e 1898#endif
61ae2fbf 1899#ifdef __MINT__
4eb8286e 1900 printf("MiNT port by Guido Flohr, 1997-1999\n");
61ae2fbf 1901#endif
baed7233
DL		 1902#ifdef BINARY_BUILD_NOTICE
1903 BINARY_BUILD_NOTICE;
1904#endif
760ac839 1905 printf("\n\
79072805 1906Perl may be copied only under the terms of either the Artistic License or the\n\
95103687
GS		 1907GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n\
1908Complete documentation for Perl, including FAQ lists, should be found on\n\
1909this system using `man perl' or `perldoc perl'. If you have access to the\n\
1910Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n");
6ad3d225 1911 PerlProc_exit(0);
79072805 1912 case 'w':
599cee73
PM		 1913 if (! (PL_dowarn & G_WARN_ALL_MASK))
1914 PL_dowarn |= G_WARN_ON;
1915 s++;
1916 return s;
1917 case 'W':
1918 PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
e24b16f9 1919 PL_compiling.cop_warnings = WARN_ALL ;
599cee73
PM		 1920 s++;
1921 return s;
1922 case 'X':
1923 PL_dowarn = G_WARN_ALL_OFF;
e24b16f9 1924 PL_compiling.cop_warnings = WARN_NONE ;
79072805
LW		 1925 s++;
1926 return s;
a0d0e21e 1927 case '*':
79072805
LW		 1928 case ' ':
1929 if (s[1] == '-') /* Additional switches on #! line. */
1930 return s+2;
1931 break;
a0d0e21e 1932 case '-':
79072805 1933 case 0:
51882d45 1934#if defined(WIN32) || !defined(PERL_STRICT_CR)
a868473f
NIS		 1935 case '\r':
1936#endif
79072805
LW		 1937 case '\n':
1938 case '\t':
1939 break;
aa689395 1940#ifdef ALTERNATE_SHEBANG
1941 case 'S': /* OS/2 needs -S on "extproc" line. */
1942 break;
1943#endif
a0d0e21e 1944 case 'P':
3280af22 1945 if (PL_preprocess)
a0d0e21e
LW		 1946 return s+1;
1947 /* FALL THROUGH */
79072805 1948 default:
cea2e8a9 1949 Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
79072805
LW		 1950 }
1951 return Nullch;
1952}
1953
1954/* compliments of Tom Christiansen */
1955
1956/* unexec() can be found in the Gnu emacs distribution */
ee580363 1957/* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
79072805
LW		 1958
1959void
864dbfa3 1960Perl_my_unexec(pTHX)
79072805
LW		 1961{
1962#ifdef UNEXEC
46fc3d4c 1963 SV* prog;
1964 SV* file;
ee580363 1965 int status = 1;
79072805
LW		 1966 extern int etext;
1967
ee580363 1968 prog = newSVpv(BIN_EXP, 0);
46fc3d4c 1969 sv_catpv(prog, "/perl");
6b88bc9c 1970 file = newSVpv(PL_origfilename, 0);
46fc3d4c 1971 sv_catpv(file, ".perldump");
79072805 1972
ee580363
GS		 1973 unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
1974 /* unexec prints msg to stderr in case of failure */
6ad3d225 1975 PerlProc_exit(status);
79072805 1976#else
a5f75d66
AD		 1977# ifdef VMS
1978# include <lib$routines.h>
1979 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
aa689395 1980# else
79072805 1981 ABORT(); /* for use with undump */
aa689395 1982# endif
a5f75d66 1983#endif
79072805
LW		 1984}
1985
cb68f92d
GS		 1986/* initialize curinterp */
1987STATIC void
cea2e8a9 1988S_init_interp(pTHX)
cb68f92d
GS		 1989{
1990
066ef5b5 1991#ifdef PERL_OBJECT /* XXX kludge */
cb68f92d 1992#define I_REINIT \
6b88bc9c
GS		 1993 STMT_START { \
1994 PL_chopset = " \n-"; \
1995 PL_copline = NOLINE; \
1996 PL_curcop = &PL_compiling;\
1997 PL_curcopdb = NULL; \
1998 PL_dbargs = 0; \
3967c732 1999 PL_dumpindent = 4; \
6b88bc9c
GS		 2000 PL_laststatval = -1; \
2001 PL_laststype = OP_STAT; \
2002 PL_maxscream = -1; \
2003 PL_maxsysfd = MAXSYSFD; \
2004 PL_statname = Nullsv; \
2005 PL_tmps_floor = -1; \
2006 PL_tmps_ix = -1; \
2007 PL_op_mask = NULL; \
6b88bc9c
GS		 2008 PL_laststatval = -1; \
2009 PL_laststype = OP_STAT; \
2010 PL_mess_sv = Nullsv; \
2011 PL_splitstr = " "; \
2012 PL_generation = 100; \
2013 PL_exitlist = NULL; \
2014 PL_exitlistlen = 0; \
2015 PL_regindent = 0; \
2016 PL_in_clean_objs = FALSE; \
2017 PL_in_clean_all = FALSE; \
2018 PL_profiledata = NULL; \
2019 PL_rsfp = Nullfp; \
2020 PL_rsfp_filters = Nullav; \
24d3c518 2021 PL_dirty = FALSE; \
cb68f92d 2022 } STMT_END
9666903d 2023 I_REINIT;
066ef5b5
GS		 2024#else
2025# ifdef MULTIPLICITY
2026# define PERLVAR(var,type)
51371543 2027# define PERLVARA(var,n,type)
cea2e8a9 2028# if defined(PERL_IMPLICIT_CONTEXT)
54aff467
GS		 2029# if defined(USE_THREADS)
2030# define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
2031# define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
2032# else /* !USE_THREADS */
2033# define PERLVARI(var,type,init) aTHX->var = init;
2034# define PERLVARIC(var,type,init) aTHX->var = init;
2035# endif /* USE_THREADS */
cea2e8a9 2036# else
c5be433b
GS		 2037# define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
2038# define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
cea2e8a9 2039# endif
066ef5b5
GS		 2040# include "intrpvar.h"
2041# ifndef USE_THREADS
2042# include "thrdvar.h"
2043# endif
2044# undef PERLVAR
51371543 2045# undef PERLVARA
066ef5b5
GS		 2046# undef PERLVARI
2047# undef PERLVARIC
3967c732 2048# else
066ef5b5 2049# define PERLVAR(var,type)
51371543 2050# define PERLVARA(var,n,type)
533c011a
NIS		 2051# define PERLVARI(var,type,init) PL_##var = init;
2052# define PERLVARIC(var,type,init) PL_##var = init;
066ef5b5
GS		 2053# include "intrpvar.h"
2054# ifndef USE_THREADS
2055# include "thrdvar.h"
2056# endif
2057# undef PERLVAR
51371543 2058# undef PERLVARA
066ef5b5
GS		 2059# undef PERLVARI
2060# undef PERLVARIC
2061# endif
cb68f92d
GS		 2062#endif
2063
cb68f92d
GS		 2064}
2065
76e3520e 2066STATIC void
cea2e8a9 2067S_init_main_stash(pTHX)
79072805 2068{
11343788 2069 dTHR;
463ee0b2 2070 GV *gv;
6e72f9df 2071
2072 /* Note that strtab is a rather special HV. Assumptions are made
2073 about not iterating on it, and not adding tie magic to it.
2074 It is properly deallocated in perl_destruct() */
3280af22 2075 PL_strtab = newHV();
5f08fbcd
GS		 2076#ifdef USE_THREADS
2077 MUTEX_INIT(&PL_strtab_mutex);
2078#endif
3280af22
NIS		 2079 HvSHAREKEYS_off(PL_strtab); /* mandatory */
2080 hv_ksplit(PL_strtab, 512);
6e72f9df 2081
3280af22 2082 PL_curstash = PL_defstash = newHV();
79cb57f6 2083 PL_curstname = newSVpvn("main",4);
adbc6bb1
LW		 2084 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
2085 SvREFCNT_dec(GvHV(gv));
3280af22 2086 GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);
463ee0b2 2087 SvREADONLY_on(gv);
3280af22
NIS		 2088 HvNAME(PL_defstash) = savepv("main");
2089 PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
2090 GvMULTI_on(PL_incgv);
2091 PL_hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */
2092 GvMULTI_on(PL_hintgv);
2093 PL_defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
2094 PL_errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
2095 GvMULTI_on(PL_errgv);
2096 PL_replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */
2097 GvMULTI_on(PL_replgv);
cea2e8a9 2098 (void)Perl_form(aTHX_ "%240s",""); /* Preallocate temp - for immediate signals. */
38a03e6e
MB		 2099 sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
2100 sv_setpvn(ERRSV, "", 0);
3280af22 2101 PL_curstash = PL_defstash;
11faa288 2102 CopSTASH_set(&PL_compiling, PL_defstash);
ed094faf 2103 PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
3280af22 2104 PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
4633a7c4 2105 /* We must init $/ before switches are processed. */
864dbfa3 2106 sv_setpvn(get_sv("/", TRUE), "\n", 1);
79072805
LW		 2107}
2108
76e3520e 2109STATIC void
cea2e8a9 2110S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript)
79072805 2111{
0f15f207 2112 dTHR;
79072805 2113 register char *s;
2a92aaa0 2114
6c4ab083 2115 *fdscript = -1;
79072805 2116
3280af22
NIS		 2117 if (PL_e_script) {
2118 PL_origfilename = savepv("-e");
96436eeb 2119 }
6c4ab083
GS		 2120 else {
2121 /* if find_script() returns, it returns a malloc()-ed value */
3280af22 2122 PL_origfilename = scriptname = find_script(scriptname, dosearch, NULL, 1);
6c4ab083
GS		 2123
2124 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
2125 char *s = scriptname + 8;
2126 *fdscript = atoi(s);
2127 while (isDIGIT(*s))
2128 s++;
2129 if (*s) {
2130 scriptname = savepv(s + 1);
3280af22
NIS		 2131 Safefree(PL_origfilename);
2132 PL_origfilename = scriptname;
6c4ab083
GS		 2133 }
2134 }
2135 }
2136
57843af0 2137 CopFILE_set(PL_curcop, PL_origfilename);
3280af22 2138 if (strEQ(PL_origfilename,"-"))
79072805 2139 scriptname = "";
01f988be 2140 if (*fdscript >= 0) {
3280af22 2141 PL_rsfp = PerlIO_fdopen(*fdscript,PERL_SCRIPT_MODE);
96436eeb 2142#if defined(HAS_FCNTL) && defined(F_SETFD)
3280af22
NIS		 2143 if (PL_rsfp)
2144 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1); /* ensure close-on-exec */
96436eeb 2145#endif
2146 }
3280af22 2147 else if (PL_preprocess) {
46fc3d4c 2148 char *cpp_cfg = CPPSTDIN;
79cb57f6 2149 SV *cpp = newSVpvn("",0);
46fc3d4c 2150 SV *cmd = NEWSV(0,0);
2151
2152 if (strEQ(cpp_cfg, "cppstdin"))
cea2e8a9 2153 Perl_sv_catpvf(aTHX_ cpp, "%s/", BIN_EXP);
46fc3d4c 2154 sv_catpv(cpp, cpp_cfg);
79072805 2155
0df16ed7 2156 sv_catpvn(sv, "-I", 2);
fed7345c 2157 sv_catpv(sv,PRIVLIB_EXP);
46fc3d4c 2158
79072805 2159#ifdef MSDOS
cea2e8a9 2160 Perl_sv_setpvf(aTHX_ cmd, "\
79072805
LW		 2161sed %s -e \"/^[^#]/b\" \
2162 -e \"/^#[ ]*include[ ]/b\" \
2163 -e \"/^#[ ]*define[ ]/b\" \
2164 -e \"/^#[ ]*if[ ]/b\" \
2165 -e \"/^#[ ]*ifdef[ ]/b\" \
2166 -e \"/^#[ ]*ifndef[ ]/b\" \
2167 -e \"/^#[ ]*else/b\" \
2168 -e \"/^#[ ]*elif[ ]/b\" \
2169 -e \"/^#[ ]*undef[ ]/b\" \
2170 -e \"/^#[ ]*endif/b\" \
2171 -e \"s/^#.*//\" \
fc36a67e 2172 %s | %_ -C %_ %s",
6b88bc9c 2173 (PL_doextract ? "-e \"1,/^#/d\n\"" : ""),
79072805 2174#else
092bebab 2175# ifdef __OPEN_VM
cea2e8a9 2176 Perl_sv_setpvf(aTHX_ cmd, "\
092bebab
JH		 2177%s %s -e '/^[^#]/b' \
2178 -e '/^#[ ]*include[ ]/b' \
2179 -e '/^#[ ]*define[ ]/b' \
2180 -e '/^#[ ]*if[ ]/b' \
2181 -e '/^#[ ]*ifdef[ ]/b' \
2182 -e '/^#[ ]*ifndef[ ]/b' \
2183 -e '/^#[ ]*else/b' \
2184 -e '/^#[ ]*elif[ ]/b' \
2185 -e '/^#[ ]*undef[ ]/b' \
2186 -e '/^#[ ]*endif/b' \
2187 -e 's/^[ ]*#.*//' \
2188 %s | %_ %_ %s",
2189# else
cea2e8a9 2190 Perl_sv_setpvf(aTHX_ cmd, "\
79072805
LW		 2191%s %s -e '/^[^#]/b' \
2192 -e '/^#[ ]*include[ ]/b' \
2193 -e '/^#[ ]*define[ ]/b' \
2194 -e '/^#[ ]*if[ ]/b' \
2195 -e '/^#[ ]*ifdef[ ]/b' \
2196 -e '/^#[ ]*ifndef[ ]/b' \
2197 -e '/^#[ ]*else/b' \
2198 -e '/^#[ ]*elif[ ]/b' \
2199 -e '/^#[ ]*undef[ ]/b' \
2200 -e '/^#[ ]*endif/b' \
2201 -e 's/^[ ]*#.*//' \
fc36a67e 2202 %s | %_ -C %_ %s",
092bebab 2203# endif
79072805
LW		 2204#ifdef LOC_SED
2205 LOC_SED,
2206#else
2207 "sed",
2208#endif
3280af22 2209 (PL_doextract ? "-e '1,/^#/d\n'" : ""),
79072805 2210#endif
46fc3d4c 2211 scriptname, cpp, sv, CPPMINUS);
3280af22 2212 PL_doextract = FALSE;
79072805 2213#ifdef IAMSUID /* actually, this is caught earlier */
b28d0864 2214 if (PL_euid != PL_uid && !PL_euid) { /* if running suidperl */
79072805 2215#ifdef HAS_SETEUID
b28d0864 2216 (void)seteuid(PL_uid); /* musn't stay setuid root */
79072805
LW		 2217#else
2218#ifdef HAS_SETREUID
b28d0864 2219 (void)setreuid((Uid_t)-1, PL_uid);
85e6fe83
LW		 2220#else
2221#ifdef HAS_SETRESUID
b28d0864 2222 (void)setresuid((Uid_t)-1, PL_uid, (Uid_t)-1);
79072805 2223#else
b28d0864 2224 PerlProc_setuid(PL_uid);
79072805
LW		 2225#endif
2226#endif
85e6fe83 2227#endif
b28d0864 2228 if (PerlProc_geteuid() != PL_uid)
cea2e8a9 2229 Perl_croak(aTHX_ "Can't do seteuid!\n");
79072805
LW		 2230 }
2231#endif /* IAMSUID */
3280af22 2232 PL_rsfp = PerlProc_popen(SvPVX(cmd), "r");
46fc3d4c 2233 SvREFCNT_dec(cmd);
2234 SvREFCNT_dec(cpp);
79072805
LW		 2235 }
2236 else if (!*scriptname) {
bbce6d69 2237 forbid_setid("program input from stdin");
3280af22 2238 PL_rsfp = PerlIO_stdin();
79072805 2239 }
96436eeb 2240 else {
3280af22 2241 PL_rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
96436eeb 2242#if defined(HAS_FCNTL) && defined(F_SETFD)
3280af22
NIS		 2243 if (PL_rsfp)
2244 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1); /* ensure close-on-exec */
96436eeb 2245#endif
2246 }
3280af22 2247 if (!PL_rsfp) {
13281fa4 2248#ifdef DOSUID
a687059c 2249#ifndef IAMSUID /* in case script is not readable before setuid */
6b88bc9c 2250 if (PL_euid &&
cc49e20b 2251 PerlLIO_stat(CopFILE(PL_curcop),&PL_statbuf) >= 0 &&
6b88bc9c
GS		 2252 PL_statbuf.st_mode & (S_ISUID|S_ISGID))
2253 {
46fc3d4c 2254 /* try again */
cea2e8a9
GS		 2255 PerlProc_execv(Perl_form(aTHX_ "%s/sperl%s", BIN_EXP, PL_patchlevel), PL_origargv);
2256 Perl_croak(aTHX_ "Can't do setuid\n");
13281fa4
LW		 2257 }
2258#endif
2259#endif
cea2e8a9 2260 Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
cc49e20b 2261 CopFILE(PL_curcop), Strerror(errno));
13281fa4 2262 }
79072805 2263}
8d063cd8 2264
7b89560d
JH		 2265/* Mention
2266 * I_SYSSTATVFS HAS_FSTATVFS
2267 * I_SYSMOUNT
2268 * I_STATFS HAS_FSTATFS
2269 * I_MNTENT HAS_GETMNTENT HAS_HASMNTOPT
2270 * here so that metaconfig picks them up. */
2271
104d25b7 2272#ifdef IAMSUID
864dbfa3 2273STATIC int
e688b231 2274S_fd_on_nosuid_fs(pTHX_ int fd)
104d25b7 2275{
0545a864
JH		 2276 int check_okay = 0; /* able to do all the required sys/libcalls */
2277 int on_nosuid = 0; /* the fd is on a nosuid fs */
104d25b7 2278/*
ad27e871 2279 * Preferred order: fstatvfs(), fstatfs(), ustat()+getmnt(), getmntent().
e688b231 2280 * fstatvfs() is UNIX98.
0545a864 2281 * fstatfs() is 4.3 BSD.
ad27e871 2282 * ustat()+getmnt() is pre-4.3 BSD.
0545a864
JH		 2283 * getmntent() is O(number-of-mounted-filesystems) and can hang on
2284 * an irrelevant filesystem while trying to reach the right one.
104d25b7
JH		 2285 */
2286
2287# ifdef HAS_FSTATVFS
2288 struct statvfs stfs;
2289 check_okay = fstatvfs(fd, &stfs) == 0;
2290 on_nosuid = check_okay && (stfs.f_flag & ST_NOSUID);
2291# else
0545a864 2292# ifdef PERL_MOUNT_NOSUID
ad27e871
JH		 2293# if defined(HAS_FSTATFS) && \
2294 defined(HAS_STRUCT_STATFS) && \
2295 defined(HAS_STRUCT_STATFS_F_FLAGS)
e688b231 2296 struct statfs stfs;
104d25b7 2297 check_okay = fstatfs(fd, &stfs) == 0;
104d25b7 2298 on_nosuid = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID);
0545a864
JH		 2299# else
2300# if defined(HAS_FSTAT) && \
2301 defined(HAS_USTAT) && \
ad27e871 2302 defined(HAS_GETMNT) && \
65d1664e 2303 defined(HAS_STRUCT_FS_DATA) && \
ad27e871 2304 defined(NOSTAT_ONE)
0545a864
JH		 2305 struct stat fdst;
2306 if (fstat(fd, &fdst) == 0) {
2307 struct ustat us;
2308 if (ustat(fdst.st_dev, &us) == 0) {
2309 struct fs_data fsd;
ad27e871
JH		 2310 /* NOSTAT_ONE here because we're not examining fields which
2311 * vary between that case and STAT_ONE. */
2312 if (getmnt((int*)0, &fsd, (int)0, NOSTAT_ONE, us.f_fname) == 0) {
0545a864
JH		 2313 size_t cmplen = sizeof(us.f_fname);
2314 if (sizeof(fsd.fd_req.path) < cmplen)
2315 cmplen = sizeof(fsd.fd_req.path);
2316 if (strnEQ(fsd.fd_req.path, us.f_fname, cmplen) &&
2317 fdst.st_dev == fsd.fd_req.dev) {
2318 check_okay = 1;
2319 on_nosuid = fsd.fd_req.flags & PERL_MOUNT_NOSUID;
2320 }
2321 }
2322 }
2323 }
2324 }
ad27e871
JH		 2325# endif /* fstat+ustat+getmnt */
2326# endif /* fstatfs */
104d25b7 2327# else
0545a864
JH		 2328# if defined(HAS_GETMNTENT) && \
2329 defined(HAS_HASMNTOPT) && \
2330 defined(MNTOPT_NOSUID)
104d25b7
JH		 2331 FILE *mtab = fopen("/etc/mtab", "r");
2332 struct mntent *entry;
2333 struct stat stb, fsb;
2334
2335 if (mtab && (fstat(fd, &stb) == 0)) {
e688b231
JH		 2336 while (entry = getmntent(mtab)) {
2337 if (stat(entry->mnt_dir, &fsb) == 0
2338 && fsb.st_dev == stb.st_dev)
104d25b7
JH		 2339 {
2340 /* found the filesystem */
2341 check_okay = 1;
2342 if (hasmntopt(entry, MNTOPT_NOSUID))
2343 on_nosuid = 1;
2344 break;
e688b231 2345 } /* A single fs may well fail its stat(). */
104d25b7
JH		 2346 }
2347 }
2348 if (mtab)
2349 fclose(mtab);
ad27e871 2350# endif /* getmntent+hasmntopt */
0545a864 2351# endif /* PERL_MOUNT_NOSUID: fstatfs or fstat+ustat+statfs */
e688b231 2352# endif /* statvfs */
0545a864 2353
104d25b7 2354 if (!check_okay)
0545a864 2355 Perl_croak(aTHX_ "Can't check filesystem of script \"%s\" for nosuid", PL_origfilename);
104d25b7
JH		 2356 return on_nosuid;
2357}
2358#endif /* IAMSUID */
2359
76e3520e 2360STATIC void
cea2e8a9 2361S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript)
79072805 2362{
96436eeb 2363 int which;
2364
13281fa4
LW		 2365 /* do we need to emulate setuid on scripts? */
2366
2367 /* This code is for those BSD systems that have setuid #! scripts disabled
2368 * in the kernel because of a security problem. Merely defining DOSUID
2369 * in perl will not fix that problem, but if you have disabled setuid
2370 * scripts in the kernel, this will attempt to emulate setuid and setgid
2371 * on scripts that have those now-otherwise-useless bits set. The setuid
27e2fb84
LW		 2372 * root version must be called suidperl or sperlN.NNN. If regular perl
2373 * discovers that it has opened a setuid script, it calls suidperl with
2374 * the same argv that it had. If suidperl finds that the script it has
2375 * just opened is NOT setuid root, it sets the effective uid back to the
2376 * uid. We don't just make perl setuid root because that loses the
2377 * effective uid we had before invoking perl, if it was different from the
2378 * uid.
13281fa4
LW		 2379 *
2380 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
2381 * be defined in suidperl only. suidperl must be setuid root. The
2382 * Configure script will set this up for you if you want it.
2383 */
a687059c 2384
13281fa4 2385#ifdef DOSUID
ea0efc06 2386 dTHR;
6e72f9df 2387 char *s, *s2;
a0d0e21e 2388
b28d0864 2389 if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0) /* normal stat is insecure */
cea2e8a9 2390 Perl_croak(aTHX_ "Can't stat script \"%s\"",PL_origfilename);
b28d0864 2391 if (fdscript < 0 && PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
79072805 2392 I32 len;
2d8e6c8d 2393 STRLEN n_a;
13281fa4 2394
a687059c 2395#ifdef IAMSUID
fe14fcc3 2396#ifndef HAS_SETREUID
a687059c
LW		 2397 /* On this access check to make sure the directories are readable,
2398 * there is actually a small window that the user could use to make
2399 * filename point to an accessible directory. So there is a faint
2400 * chance that someone could execute a setuid script down in a
2401 * non-accessible directory. I don't know what to do about that.
2402 * But I don't think it's too important. The manual lies when
2403 * it says access() is useful in setuid programs.
2404 */
cc49e20b 2405 if (PerlLIO_access(CopFILE(PL_curcop),1)) /*double check*/
cea2e8a9 2406 Perl_croak(aTHX_ "Permission denied");
a687059c
LW		 2407#else
2408 /* If we can swap euid and uid, then we can determine access rights
2409 * with a simple stat of the file, and then compare device and
2410 * inode to make sure we did stat() on the same file we opened.
2411 * Then we just have to make sure he or she can execute it.
2412 */
2413 {
2414 struct stat tmpstatbuf;
2415
85e6fe83
LW		 2416 if (
2417#ifdef HAS_SETREUID
b28d0864 2418 setreuid(PL_euid,PL_uid) < 0
a0d0e21e
LW		 2419#else
2420# if HAS_SETRESUID
b28d0864 2421 setresuid(PL_euid,PL_uid,(Uid_t)-1) < 0
a0d0e21e 2422# endif
85e6fe83 2423#endif
b28d0864 2424 || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
cea2e8a9 2425 Perl_croak(aTHX_ "Can't swap uid and euid"); /* really paranoid */
cc49e20b 2426 if (PerlLIO_stat(CopFILE(PL_curcop),&tmpstatbuf) < 0)
cea2e8a9 2427 Perl_croak(aTHX_ "Permission denied"); /* testing full pathname here */
2bb3463c 2428#if defined(IAMSUID) && !defined(NO_NOSUID_CHECK)
e688b231 2429 if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp)))
cea2e8a9 2430 Perl_croak(aTHX_ "Permission denied");
104d25b7 2431#endif
b28d0864
NIS		 2432 if (tmpstatbuf.st_dev != PL_statbuf.st_dev ||
2433 tmpstatbuf.st_ino != PL_statbuf.st_ino) {
2434 (void)PerlIO_close(PL_rsfp);
2435 if (PL_rsfp = PerlProc_popen("/bin/mail root","w")) { /* heh, heh */
2436 PerlIO_printf(PL_rsfp,
785fb66b
JH		 2437"User %"Uid_t_f" tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
2438(Filename of set-id script was %s, uid %"Uid_t_f" gid %"Gid_t_f".)\n\nSincerely,\nperl\n",
2439 PL_uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
b28d0864 2440 (long)PL_statbuf.st_dev, (long)PL_statbuf.st_ino,
cc49e20b 2441 CopFILE(PL_curcop),
785fb66b 2442 PL_statbuf.st_uid, PL_statbuf.st_gid);
b28d0864 2443 (void)PerlProc_pclose(PL_rsfp);
a687059c 2444 }
cea2e8a9 2445 Perl_croak(aTHX_ "Permission denied\n");
a687059c 2446 }
85e6fe83
LW		 2447 if (
2448#ifdef HAS_SETREUID
b28d0864 2449 setreuid(PL_uid,PL_euid) < 0
a0d0e21e
LW		 2450#else
2451# if defined(HAS_SETRESUID)
b28d0864 2452 setresuid(PL_uid,PL_euid,(Uid_t)-1) < 0
a0d0e21e 2453# endif
85e6fe83 2454#endif
b28d0864 2455 || PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid)
cea2e8a9 2456 Perl_croak(aTHX_ "Can't reswap uid and euid");
b28d0864 2457 if (!cando(S_IXUSR,FALSE,&PL_statbuf)) /* can real uid exec? */
cea2e8a9 2458 Perl_croak(aTHX_ "Permission denied\n");
a687059c 2459 }
fe14fcc3 2460#endif /* HAS_SETREUID */
a687059c
LW		 2461#endif /* IAMSUID */
2462
b28d0864 2463 if (!S_ISREG(PL_statbuf.st_mode))
cea2e8a9 2464 Perl_croak(aTHX_ "Permission denied");
b28d0864 2465 if (PL_statbuf.st_mode & S_IWOTH)
cea2e8a9 2466 Perl_croak(aTHX_ "Setuid/gid script is writable by world");
6b88bc9c 2467 PL_doswitches = FALSE; /* -s is insecure in suid */
57843af0 2468 CopLINE_inc(PL_curcop);
6b88bc9c 2469 if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch ||
2d8e6c8d 2470 strnNE(SvPV(PL_linestr,n_a),"#!",2) ) /* required even on Sys V */
cea2e8a9 2471 Perl_croak(aTHX_ "No #! line");
2d8e6c8d 2472 s = SvPV(PL_linestr,n_a)+2;
663a0e37 2473 if (*s == ' ') s++;
45d8adaa 2474 while (!isSPACE(*s)) s++;
2d8e6c8d 2475 for (s2 = s; (s2 > SvPV(PL_linestr,n_a)+2 &&
6e72f9df 2476 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
2477 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
cea2e8a9 2478 Perl_croak(aTHX_ "Not a perl script");
a687059c 2479 while (*s == ' ' || *s == '\t') s++;
13281fa4
LW		 2480 /*
2481 * #! arg must be what we saw above. They can invoke it by
2482 * mentioning suidperl explicitly, but they may not add any strange
2483 * arguments beyond what #! says if they do invoke suidperl that way.
2484 */
2485 len = strlen(validarg);
2486 if (strEQ(validarg," PHOOEY ") ||
45d8adaa 2487 strnNE(s,validarg,len) || !isSPACE(s[len]))
cea2e8a9 2488 Perl_croak(aTHX_ "Args must match #! line");
a687059c
LW		 2489
2490#ifndef IAMSUID
b28d0864
NIS		 2491 if (PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
2492 PL_euid == PL_statbuf.st_uid)
2493 if (!PL_do_undump)
cea2e8a9 2494 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
a687059c
LW		 2495FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2496#endif /* IAMSUID */
13281fa4 2497
b28d0864
NIS		 2498 if (PL_euid) { /* oops, we're not the setuid root perl */
2499 (void)PerlIO_close(PL_rsfp);
13281fa4 2500#ifndef IAMSUID
46fc3d4c 2501 /* try again */
cea2e8a9 2502 PerlProc_execv(Perl_form(aTHX_ "%s/sperl%s", BIN_EXP, PL_patchlevel), PL_origargv);
13281fa4 2503#endif
cea2e8a9 2504 Perl_croak(aTHX_ "Can't do setuid\n");
13281fa4
LW		 2505 }
2506
b28d0864 2507 if (PL_statbuf.st_mode & S_ISGID && PL_statbuf.st_gid != PL_egid) {
fe14fcc3 2508#ifdef HAS_SETEGID
b28d0864 2509 (void)setegid(PL_statbuf.st_gid);
a687059c 2510#else
fe14fcc3 2511#ifdef HAS_SETREGID
b28d0864 2512 (void)setregid((Gid_t)-1,PL_statbuf.st_gid);
85e6fe83
LW		 2513#else
2514#ifdef HAS_SETRESGID
b28d0864 2515 (void)setresgid((Gid_t)-1,PL_statbuf.st_gid,(Gid_t)-1);
a687059c 2516#else
b28d0864 2517 PerlProc_setgid(PL_statbuf.st_gid);
a687059c
LW		 2518#endif
2519#endif
85e6fe83 2520#endif
b28d0864 2521 if (PerlProc_getegid() != PL_statbuf.st_gid)
cea2e8a9 2522 Perl_croak(aTHX_ "Can't do setegid!\n");
83025b21 2523 }
b28d0864
NIS		 2524 if (PL_statbuf.st_mode & S_ISUID) {
2525 if (PL_statbuf.st_uid != PL_euid)
fe14fcc3 2526#ifdef HAS_SETEUID
b28d0864 2527 (void)seteuid(PL_statbuf.st_uid); /* all that for this */
a687059c 2528#else
fe14fcc3 2529#ifdef HAS_SETREUID
b28d0864 2530 (void)setreuid((Uid_t)-1,PL_statbuf.st_uid);
85e6fe83
LW		 2531#else
2532#ifdef HAS_SETRESUID
b28d0864 2533 (void)setresuid((Uid_t)-1,PL_statbuf.st_uid,(Uid_t)-1);
a687059c 2534#else
b28d0864 2535 PerlProc_setuid(PL_statbuf.st_uid);
a687059c
LW		 2536#endif
2537#endif
85e6fe83 2538#endif
b28d0864 2539 if (PerlProc_geteuid() != PL_statbuf.st_uid)
cea2e8a9 2540 Perl_croak(aTHX_ "Can't do seteuid!\n");
a687059c 2541 }
b28d0864 2542 else if (PL_uid) { /* oops, mustn't run as root */
fe14fcc3 2543#ifdef HAS_SETEUID
b28d0864 2544 (void)seteuid((Uid_t)PL_uid);
a687059c 2545#else
fe14fcc3 2546#ifdef HAS_SETREUID
b28d0864 2547 (void)setreuid((Uid_t)-1,(Uid_t)PL_uid);
a687059c 2548#else
85e6fe83 2549#ifdef HAS_SETRESUID
b28d0864 2550 (void)setresuid((Uid_t)-1,(Uid_t)PL_uid,(Uid_t)-1);
85e6fe83 2551#else
b28d0864 2552 PerlProc_setuid((Uid_t)PL_uid);
85e6fe83 2553#endif
a687059c
LW		 2554#endif
2555#endif
b28d0864 2556 if (PerlProc_geteuid() != PL_uid)
cea2e8a9 2557 Perl_croak(aTHX_ "Can't do seteuid!\n");
83025b21 2558 }
748a9306 2559 init_ids();
b28d0864 2560 if (!cando(S_IXUSR,TRUE,&PL_statbuf))
cea2e8a9 2561 Perl_croak(aTHX_ "Permission denied\n"); /* they can't do this */
13281fa4
LW		 2562 }
2563#ifdef IAMSUID
6b88bc9c 2564 else if (PL_preprocess)
cea2e8a9 2565 Perl_croak(aTHX_ "-P not allowed for setuid/setgid script\n");
96436eeb 2566 else if (fdscript >= 0)
cea2e8a9 2567 Perl_croak(aTHX_ "fd script not allowed in suidperl\n");
13281fa4 2568 else
cea2e8a9 2569 Perl_croak(aTHX_ "Script is not setuid/setgid in suidperl\n");
96436eeb 2570
2571 /* We absolutely must clear out any saved ids here, so we */
2572 /* exec the real perl, substituting fd script for scriptname. */
2573 /* (We pass script name as "subdir" of fd, which perl will grok.) */
b28d0864
NIS		 2574 PerlIO_rewind(PL_rsfp);
2575 PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0); /* just in case rewind didn't */
6b88bc9c
GS		 2576 for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;
2577 if (!PL_origargv[which])
cea2e8a9
GS		 2578 Perl_croak(aTHX_ "Permission denied");
2579 PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s",
6b88bc9c 2580 PerlIO_fileno(PL_rsfp), PL_origargv[which]));
96436eeb 2581#if defined(HAS_FCNTL) && defined(F_SETFD)
b28d0864 2582 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0); /* ensure no close-on-exec */
96436eeb 2583#endif
cea2e8a9
GS		 2584 PerlProc_execv(Perl_form(aTHX_ "%s/perl%s", BIN_EXP, PL_patchlevel), PL_origargv);/* try again */
2585 Perl_croak(aTHX_ "Can't do setuid\n");
13281fa4 2586#endif /* IAMSUID */
a687059c 2587#else /* !DOSUID */
3280af22 2588 if (PL_euid != PL_uid || PL_egid != PL_gid) { /* (suidperl doesn't exist, in fact) */
a687059c 2589#ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
96827780 2590 dTHR;
b28d0864
NIS		 2591 PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf); /* may be either wrapped or real suid */
2592 if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
a687059c 2593 ||
b28d0864 2594 (PL_egid != PL_gid && PL_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
a687059c 2595 )
b28d0864 2596 if (!PL_do_undump)
cea2e8a9 2597 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
a687059c
LW		 2598FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2599#endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
2600 /* not set-id, must be wrapped */
a687059c 2601 }
13281fa4 2602#endif /* DOSUID */
79072805 2603}
13281fa4 2604
76e3520e 2605STATIC void
cea2e8a9 2606S_find_beginning(pTHX)
79072805 2607{
6e72f9df 2608 register char *s, *s2;
33b78306
LW		 2609
2610 /* skip forward in input to the real script? */
2611
bbce6d69 2612 forbid_setid("-x");
3280af22
NIS		 2613 while (PL_doextract) {
2614 if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch)
cea2e8a9 2615 Perl_croak(aTHX_ "No Perl script found in input\n");
6e72f9df 2616 if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
3280af22
NIS		 2617 PerlIO_ungetc(PL_rsfp, '\n'); /* to keep line count right */
2618 PL_doextract = FALSE;
6e72f9df 2619 while (*s && !(isSPACE (*s) || *s == '#')) s++;
2620 s2 = s;
2621 while (*s == ' ' || *s == '\t') s++;
2622 if (*s++ == '-') {
2623 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2624 if (strnEQ(s2-4,"perl",4))
2625 /*SUPPRESS 530*/
2626 while (s = moreswitches(s)) ;
33b78306 2627 }
83025b21
LW		 2628 }
2629 }
2630}
2631
afe37c7d 2632
76e3520e 2633STATIC void
cea2e8a9 2634S_init_ids(pTHX)
352d5a3a 2635{
d8eceb89
JH		 2636 PL_uid = PerlProc_getuid();
2637 PL_euid = PerlProc_geteuid();
2638 PL_gid = PerlProc_getgid();
2639 PL_egid = PerlProc_getegid();
748a9306 2640#ifdef VMS
b28d0864
NIS		 2641 PL_uid |= PL_gid << 16;
2642 PL_euid |= PL_egid << 16;
748a9306 2643#endif
3280af22 2644 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
748a9306 2645}
79072805 2646
76e3520e 2647STATIC void
cea2e8a9 2648S_forbid_setid(pTHX_ char *s)
bbce6d69 2649{
3280af22 2650 if (PL_euid != PL_uid)
cea2e8a9 2651 Perl_croak(aTHX_ "No %s allowed while running setuid", s);
3280af22 2652 if (PL_egid != PL_gid)
cea2e8a9 2653 Perl_croak(aTHX_ "No %s allowed while running setgid", s);
bbce6d69 2654}
2655
1ee4443e
IZ		 2656void
2657Perl_init_debugger(pTHX)
748a9306 2658{
11343788 2659 dTHR;
1ee4443e
IZ		 2660 HV *ostash = PL_curstash;
2661
3280af22
NIS		 2662 PL_curstash = PL_debstash;
2663 PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2664 AvREAL_off(PL_dbargs);
2665 PL_DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2666 PL_DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2667 PL_DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
1ee4443e 2668 sv_upgrade(GvSV(PL_DBsub), SVt_IV); /* IVX accessed if PERLDB_SUB_NN */
3280af22
NIS		 2669 PL_DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2670 sv_setiv(PL_DBsingle, 0);
2671 PL_DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2672 sv_setiv(PL_DBtrace, 0);
2673 PL_DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2674 sv_setiv(PL_DBsignal, 0);
1ee4443e 2675 PL_curstash = ostash;
352d5a3a
LW		 2676}
2677
2ce36478
SM		 2678#ifndef STRESS_REALLOC
2679#define REASONABLE(size) (size)
2680#else
2681#define REASONABLE(size) (1) /* unreasonable */
2682#endif
2683
11343788 2684void
cea2e8a9 2685Perl_init_stacks(pTHX)
79072805 2686{
e336de0d 2687 /* start with 128-item stack and 8K cxstack */
3280af22 2688 PL_curstackinfo = new_stackinfo(REASONABLE(128),
e336de0d 2689 REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
3280af22
NIS		 2690 PL_curstackinfo->si_type = PERLSI_MAIN;
2691 PL_curstack = PL_curstackinfo->si_stack;
2692 PL_mainstack = PL_curstack; /* remember in case we switch stacks */
79072805 2693
3280af22
NIS		 2694 PL_stack_base = AvARRAY(PL_curstack);
2695 PL_stack_sp = PL_stack_base;
2696 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
8990e307 2697
3280af22
NIS		 2698 New(50,PL_tmps_stack,REASONABLE(128),SV*);
2699 PL_tmps_floor = -1;
2700 PL_tmps_ix = -1;
2701 PL_tmps_max = REASONABLE(128);
8990e307 2702
3280af22
NIS		 2703 New(54,PL_markstack,REASONABLE(32),I32);
2704 PL_markstack_ptr = PL_markstack;
2705 PL_markstack_max = PL_markstack + REASONABLE(32);
79072805 2706
ce2f7c3b 2707 SET_MARK_OFFSET;
e336de0d 2708
3280af22
NIS		 2709 New(54,PL_scopestack,REASONABLE(32),I32);
2710 PL_scopestack_ix = 0;
2711 PL_scopestack_max = REASONABLE(32);
79072805 2712
3280af22
NIS		 2713 New(54,PL_savestack,REASONABLE(128),ANY);
2714 PL_savestack_ix = 0;
2715 PL_savestack_max = REASONABLE(128);
79072805 2716
3280af22
NIS		 2717 New(54,PL_retstack,REASONABLE(16),OP*);
2718 PL_retstack_ix = 0;
2719 PL_retstack_max = REASONABLE(16);
378cc40b 2720}
33b78306 2721
2ce36478
SM		 2722#undef REASONABLE
2723
76e3520e 2724STATIC void
cea2e8a9 2725S_nuke_stacks(pTHX)
6e72f9df 2726{
e858de61 2727 dTHR;
3280af22
NIS		 2728 while (PL_curstackinfo->si_next)
2729 PL_curstackinfo = PL_curstackinfo->si_next;
2730 while (PL_curstackinfo) {
2731 PERL_SI *p = PL_curstackinfo->si_prev;
bac4b2ad 2732 /* curstackinfo->si_stack got nuked by sv_free_arenas() */
3280af22
NIS		 2733 Safefree(PL_curstackinfo->si_cxstack);
2734 Safefree(PL_curstackinfo);
2735 PL_curstackinfo = p;
e336de0d 2736 }
3280af22
NIS		 2737 Safefree(PL_tmps_stack);
2738 Safefree(PL_markstack);
2739 Safefree(PL_scopestack);
2740 Safefree(PL_savestack);
2741 Safefree(PL_retstack);
378cc40b 2742}
33b78306 2743
76e3520e 2744#ifndef PERL_OBJECT
760ac839 2745static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
76e3520e 2746#endif
7aa04957 2747
76e3520e 2748STATIC void
cea2e8a9 2749S_init_lexer(pTHX)
8990e307 2750{
76e3520e
GS		 2751#ifdef PERL_OBJECT
2752 PerlIO *tmpfp;
2753#endif
3280af22
NIS		 2754 tmpfp = PL_rsfp;
2755 PL_rsfp = Nullfp;
2756 lex_start(PL_linestr);
2757 PL_rsfp = tmpfp;
79cb57f6 2758 PL_subname = newSVpvn("main",4);
8990e307
LW		 2759}
2760
76e3520e 2761STATIC void
cea2e8a9 2762S_init_predump_symbols(pTHX)
45d8adaa 2763{
11343788 2764 dTHR;
93a17b20 2765 GV *tmpgv;
a0d0e21e 2766 GV *othergv;
af8c498a 2767 IO *io;
79072805 2768
864dbfa3 2769 sv_setpvn(get_sv("\"", TRUE), " ", 1);
3280af22
NIS		 2770 PL_stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
2771 GvMULTI_on(PL_stdingv);
af8c498a
GS		 2772 io = GvIOp(PL_stdingv);
2773 IoIFP(io) = PerlIO_stdin();
adbc6bb1 2774 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
a5f75d66 2775 GvMULTI_on(tmpgv);
af8c498a 2776 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
79072805 2777
85e6fe83 2778 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
a5f75d66 2779 GvMULTI_on(tmpgv);
af8c498a
GS		 2780 io = GvIOp(tmpgv);
2781 IoOFP(io) = IoIFP(io) = PerlIO_stdout();
4633a7c4 2782 setdefout(tmpgv);
adbc6bb1 2783 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
a5f75d66 2784 GvMULTI_on(tmpgv);
af8c498a 2785 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
79072805 2786
bf49b057
GS		 2787 PL_stderrgv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
2788 GvMULTI_on(PL_stderrgv);
2789 io = GvIOp(PL_stderrgv);
af8c498a 2790 IoOFP(io) = IoIFP(io) = PerlIO_stderr();
adbc6bb1 2791 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
a5f75d66 2792 GvMULTI_on(tmpgv);
af8c498a 2793 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
79072805 2794
3280af22 2795 PL_statname = NEWSV(66,0); /* last filename we did stat on */
ab821d7f 2796
3280af22
NIS		 2797 if (!PL_osname)
2798 PL_osname = savepv(OSNAME);
79072805 2799}
33b78306 2800
76e3520e 2801STATIC void
cea2e8a9 2802S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
33b78306 2803{
a863c7d1 2804 dTHR;
79072805
LW		 2805 char *s;
2806 SV *sv;
2807 GV* tmpgv;
fe14fcc3 2808
79072805 2809 argc--,argv++; /* skip name of script */
3280af22 2810 if (PL_doswitches) {
79072805
LW		 2811 for (; argc > 0 && **argv == '-'; argc--,argv++) {
2812 if (!argv[0][1])
2813 break;
2814 if (argv[0][1] == '-') {
2815 argc--,argv++;
2816 break;
2817 }
93a17b20 2818 if (s = strchr(argv[0], '=')) {
79072805 2819 *s++ = '\0';
85e6fe83 2820 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
79072805
LW		 2821 }
2822 else
85e6fe83 2823 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
fe14fcc3 2824 }
79072805 2825 }
3280af22
NIS		 2826 PL_toptarget = NEWSV(0,0);
2827 sv_upgrade(PL_toptarget, SVt_PVFM);
2828 sv_setpvn(PL_toptarget, "", 0);
2829 PL_bodytarget = NEWSV(0,0);
2830 sv_upgrade(PL_bodytarget, SVt_PVFM);
2831 sv_setpvn(PL_bodytarget, "", 0);
2832 PL_formtarget = PL_bodytarget;
79072805 2833
bbce6d69 2834 TAINT;
85e6fe83 2835 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
3280af22 2836 sv_setpv(GvSV(tmpgv),PL_origfilename);
79072805
LW		 2837 magicname("0", "0", 1);
2838 }
85e6fe83 2839 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
ed344e4f
IZ		 2840#ifdef OS2
2841 sv_setpv(GvSV(tmpgv), os2_execname());
2842#else
3280af22 2843 sv_setpv(GvSV(tmpgv),PL_origargv[0]);
ed344e4f 2844#endif
3280af22
NIS		 2845 if (PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
2846 GvMULTI_on(PL_argvgv);
2847 (void)gv_AVadd(PL_argvgv);
2848 av_clear(GvAVn(PL_argvgv));
79072805 2849 for (; argc > 0; argc--,argv++) {
3280af22 2850 av_push(GvAVn(PL_argvgv),newSVpv(argv[0],0));
79072805
LW		 2851 }
2852 }
3280af22 2853 if (PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
79072805 2854 HV *hv;
3280af22
NIS		 2855 GvMULTI_on(PL_envgv);
2856 hv = GvHVn(PL_envgv);
2857 hv_magic(hv, PL_envgv, 'E');
4d2c4e07 2858#if !defined( VMS) && !defined(EPOC) /* VMS doesn't have environ array */
4633a7c4
LW		 2859 /* Note that if the supplied env parameter is actually a copy
2860 of the global environ then it may now point to free'd memory
2861 if the environment has been modified since. To avoid this
2862 problem we treat env==NULL as meaning 'use the default'
2863 */
2864 if (!env)
2865 env = environ;
5aabfad6 2866 if (env != environ)
79072805
LW		 2867 environ[0] = Nullch;
2868 for (; *env; env++) {
93a17b20 2869 if (!(s = strchr(*env,'=')))
79072805
LW		 2870 continue;
2871 *s++ = '\0';
60ce6247 2872#if defined(MSDOS)
137443ea 2873 (void)strupr(*env);
2874#endif
79072805
LW		 2875 sv = newSVpv(s--,0);
2876 (void)hv_store(hv, *env, s - *env, sv, 0);
2877 *s = '=';
3e3baf6d
TB		 2878#if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV)
2879 /* Sins of the RTL. See note in my_setenv(). */
76e3520e 2880 (void)PerlEnv_putenv(savepv(*env));
3e3baf6d 2881#endif
fe14fcc3 2882 }
4550b24a 2883#endif
2884#ifdef DYNAMIC_ENV_FETCH
2885 HvNAME(hv) = savepv(ENV_HV_NAME);
2886#endif
79072805 2887 }
bbce6d69 2888 TAINT_NOT;
85e6fe83 2889 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
7766f137 2890 sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
33b78306 2891}
34de22dd 2892
76e3520e 2893STATIC void
cea2e8a9 2894S_init_perllib(pTHX)
34de22dd 2895{
85e6fe83 2896 char *s;
3280af22 2897 if (!PL_tainting) {
552a7a9b 2898#ifndef VMS
76e3520e 2899 s = PerlEnv_getenv("PERL5LIB");
85e6fe83 2900 if (s)
774d564b 2901 incpush(s, TRUE);
85e6fe83 2902 else
76e3520e 2903 incpush(PerlEnv_getenv("PERLLIB"), FALSE);
552a7a9b 2904#else /* VMS */
2905 /* Treat PERL5?LIB as a possible search list logical name -- the
2906 * "natural" VMS idiom for a Unix path string. We allow each
2907 * element to be a set of |-separated directories for compatibility.
2908 */
2909 char buf[256];
2910 int idx = 0;
2911 if (my_trnlnm("PERL5LIB",buf,0))
774d564b 2912 do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
552a7a9b 2913 else
774d564b 2914 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
552a7a9b 2915#endif /* VMS */
85e6fe83 2916 }
34de22dd 2917
c90c0ff4 2918/* Use the ~-expanded versions of APPLLIB (undocumented),
dfe9444c 2919 ARCHLIB PRIVLIB SITEARCH and SITELIB
df5cef82 2920*/
4633a7c4 2921#ifdef APPLLIB_EXP
43051805 2922 incpush(APPLLIB_EXP, TRUE);
16d20bd9 2923#endif
4633a7c4 2924
fed7345c 2925#ifdef ARCHLIB_EXP
774d564b 2926 incpush(ARCHLIB_EXP, FALSE);
a0d0e21e 2927#endif
fed7345c
AD		 2928#ifndef PRIVLIB_EXP
2929#define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
34de22dd 2930#endif
00dc2f4f
GS		 2931#if defined(WIN32)
2932 incpush(PRIVLIB_EXP, TRUE);
2933#else
774d564b 2934 incpush(PRIVLIB_EXP, FALSE);
00dc2f4f 2935#endif
4633a7c4
LW		 2936
2937#ifdef SITEARCH_EXP
774d564b 2938 incpush(SITEARCH_EXP, FALSE);
4633a7c4
LW		 2939#endif
2940#ifdef SITELIB_EXP
00dc2f4f
GS		 2941#if defined(WIN32)
2942 incpush(SITELIB_EXP, TRUE);
2943#else
774d564b 2944 incpush(SITELIB_EXP, FALSE);
4633a7c4 2945#endif
81c6dfba 2946#endif
a3635516
JH		 2947#if defined(PERL_VENDORLIB_EXP)
2948#if defined(WIN32)
265f5c4a 2949 incpush(PERL_VENDORLIB_EXP, TRUE);
a3635516
JH		 2950#else
2951 incpush(PERL_VENDORLIB_EXP, FALSE);
2952#endif
00dc2f4f 2953#endif
3280af22 2954 if (!PL_tainting)
774d564b 2955 incpush(".", FALSE);
2956}
2957
2958#if defined(DOSISH)
2959# define PERLLIB_SEP ';'
2960#else
2961# if defined(VMS)
2962# define PERLLIB_SEP '|'
2963# else
2964# define PERLLIB_SEP ':'
2965# endif
2966#endif
2967#ifndef PERLLIB_MANGLE
2968# define PERLLIB_MANGLE(s,n) (s)
2969#endif
2970
76e3520e 2971STATIC void
cea2e8a9 2972S_incpush(pTHX_ char *p, int addsubdirs)
774d564b 2973{
2974 SV *subdir = Nullsv;
774d564b 2975
2976 if (!p)
2977 return;
2978
2979 if (addsubdirs) {
00db4c45 2980 subdir = sv_newmortal();
3280af22
NIS		 2981 if (!PL_archpat_auto) {
2982 STRLEN len = (sizeof(ARCHNAME) + strlen(PL_patchlevel)
774d564b 2983 + sizeof("//auto"));
3280af22
NIS		 2984 New(55, PL_archpat_auto, len, char);
2985 sprintf(PL_archpat_auto, "/%s/%s/auto", ARCHNAME, PL_patchlevel);
aa689395 2986#ifdef VMS
2987 for (len = sizeof(ARCHNAME) + 2;
6b88bc9c
GS		 2988 PL_archpat_auto[len] != '\0' && PL_archpat_auto[len] != '/'; len++)
2989 if (PL_archpat_auto[len] == '.') PL_archpat_auto[len] = '_';
aa689395 2990#endif
774d564b 2991 }
2992 }
2993
2994 /* Break at all separators */
2995 while (p && *p) {
8c52afec 2996 SV *libdir = NEWSV(55,0);
774d564b 2997 char *s;
2998
2999 /* skip any consecutive separators */
3000 while ( *p == PERLLIB_SEP ) {
3001 /* Uncomment the next line for PATH semantics */
79cb57f6 3002 /* av_push(GvAVn(PL_incgv), newSVpvn(".", 1)); */
774d564b 3003 p++;
3004 }
3005
3006 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
3007 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
3008 (STRLEN)(s - p));
3009 p = s + 1;
3010 }
3011 else {
3012 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
3013 p = Nullch; /* break out */
3014 }
3015
3016 /*
3017 * BEFORE pushing libdir onto @INC we may first push version- and
3018 * archname-specific sub-directories.
3019 */
3020 if (addsubdirs) {
3021 struct stat tmpstatbuf;
aa689395 3022#ifdef VMS
3023 char *unix;
3024 STRLEN len;
774d564b 3025
2d8e6c8d 3026 if ((unix = tounixspec_ts(SvPV(libdir,len),Nullch)) != Nullch) {
aa689395 3027 len = strlen(unix);
3028 while (unix[len-1] == '/') len--; /* Cosmetic */
3029 sv_usepvn(libdir,unix,len);
3030 }
3031 else
bf49b057 3032 PerlIO_printf(Perl_error_log,
aa689395 3033 "Failed to unixify @INC element \"%s\"\n",
2d8e6c8d 3034 SvPV(libdir,len));
aa689395 3035#endif
4fdae800 3036 /* .../archname/version if -d .../archname/version/auto */
774d564b 3037 sv_setsv(subdir, libdir);
3280af22 3038 sv_catpv(subdir, PL_archpat_auto);
76e3520e 3039 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
774d564b 3040 S_ISDIR(tmpstatbuf.st_mode))
3280af22 3041 av_push(GvAVn(PL_incgv),
79cb57f6 3042 newSVpvn(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
774d564b 3043
4fdae800 3044 /* .../archname if -d .../archname/auto */
774d564b 3045 sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
3280af22 3046 strlen(PL_patchlevel) + 1, "", 0);
76e3520e 3047 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
774d564b 3048 S_ISDIR(tmpstatbuf.st_mode))
3280af22 3049 av_push(GvAVn(PL_incgv),
79cb57f6 3050 newSVpvn(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
774d564b 3051 }
3052
3053 /* finally push this lib directory on the end of @INC */
3280af22 3054 av_push(GvAVn(PL_incgv), libdir);
774d564b 3055 }
34de22dd 3056}
93a17b20 3057
199100c8 3058#ifdef USE_THREADS
76e3520e 3059STATIC struct perl_thread *
cea2e8a9 3060S_init_main_thread(pTHX)
199100c8 3061{
c5be433b 3062#if !defined(PERL_IMPLICIT_CONTEXT)
52e1cb5e 3063 struct perl_thread *thr;
cea2e8a9 3064#endif
199100c8
MB		 3065 XPV *xpv;
3066
52e1cb5e 3067 Newz(53, thr, 1, struct perl_thread);
533c011a 3068 PL_curcop = &PL_compiling;
c5be433b 3069 thr->interp = PERL_GET_INTERP;
199100c8 3070 thr->cvcache = newHV();
54b9620d 3071 thr->threadsv = newAV();
940cb80d 3072 /* thr->threadsvp is set when find_threadsv is called */
199100c8
MB		 3073 thr->specific = newAV();
3074 thr->flags = THRf_R_JOINABLE;
3075 MUTEX_INIT(&thr->mutex);
3076 /* Handcraft thrsv similarly to mess_sv */
533c011a 3077 New(53, PL_thrsv, 1, SV);
199100c8 3078 Newz(53, xpv, 1, XPV);
533c011a
NIS		 3079 SvFLAGS(PL_thrsv) = SVt_PV;
3080 SvANY(PL_thrsv) = (void*)xpv;
3081 SvREFCNT(PL_thrsv) = 1 << 30; /* practically infinite */
3082 SvPVX(PL_thrsv) = (char*)thr;
3083 SvCUR_set(PL_thrsv, sizeof(thr));
3084 SvLEN_set(PL_thrsv, sizeof(thr));
3085 *SvEND(PL_thrsv) = '\0'; /* in the trailing_nul field */
3086 thr->oursv = PL_thrsv;
3087 PL_chopset = " \n-";
3967c732 3088 PL_dumpindent = 4;
533c011a
NIS		 3089
3090 MUTEX_LOCK(&PL_threads_mutex);
3091 PL_nthreads++;
199100c8
MB		 3092 thr->tid = 0;
3093 thr->next = thr;
3094 thr->prev = thr;
533c011a 3095 MUTEX_UNLOCK(&PL_threads_mutex);
199100c8 3096
4b026b9e 3097#ifdef HAVE_THREAD_INTERN
4f63d024 3098 Perl_init_thread_intern(thr);
235db74f
GS		 3099#endif
3100
3101#ifdef SET_THREAD_SELF
3102 SET_THREAD_SELF(thr);
199100c8
MB		 3103#else
3104 thr->self = pthread_self();
235db74f 3105#endif /* SET_THREAD_SELF */
199100c8
MB		 3106 SET_THR(thr);
3107
3108 /*
3109 * These must come after the SET_THR because sv_setpvn does
3110 * SvTAINT and the taint fields require dTHR.
3111 */
533c011a
NIS		 3112 PL_toptarget = NEWSV(0,0);
3113 sv_upgrade(PL_toptarget, SVt_PVFM);
3114 sv_setpvn(PL_toptarget, "", 0);
3115 PL_bodytarget = NEWSV(0,0);
3116 sv_upgrade(PL_bodytarget, SVt_PVFM);
3117 sv_setpvn(PL_bodytarget, "", 0);
3118 PL_formtarget = PL_bodytarget;
79cb57f6 3119 thr->errsv = newSVpvn("", 0);
78857c3c 3120 (void) find_threadsv("@"); /* Ensure $@ is initialised early */
5c0ca799 3121
533c011a 3122 PL_maxscream = -1;
0b94c7bb
GS		 3123 PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp);
3124 PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags);
3125 PL_regint_start = MEMBER_TO_FPTR(Perl_re_intuit_start);
3126 PL_regint_string = MEMBER_TO_FPTR(Perl_re_intuit_string);
3127 PL_regfree = MEMBER_TO_FPTR(Perl_pregfree);
533c011a
NIS		 3128 PL_regindent = 0;
3129 PL_reginterp_cnt = 0;
5c0ca799 3130
199100c8
MB		 3131 return thr;
3132}
3133#endif /* USE_THREADS */
3134
93a17b20 3135void
864dbfa3 3136Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
93a17b20 3137{
11343788 3138 dTHR;
971a9dd3 3139 SV *atsv;
57843af0 3140 line_t oldline = CopLINE(PL_curcop);
312caa8e 3141 CV *cv;
22921e25 3142 STRLEN len;
6224f72b 3143 int ret;
db36c5a1 3144 dJMPENV;
93a17b20 3145
76e3520e 3146 while (AvFILL(paramList) >= 0) {
312caa8e 3147 cv = (CV*)av_shift(paramList);
8990e307 3148 SAVEFREESV(cv);
db36c5a1 3149 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_call_list_body), cv);
6224f72b 3150 switch (ret) {
312caa8e 3151 case 0:
971a9dd3 3152 atsv = ERRSV;
312caa8e
CS		 3153 (void)SvPV(atsv, len);
3154 if (len) {
971a9dd3 3155 STRLEN n_a;
312caa8e 3156 PL_curcop = &PL_compiling;
57843af0 3157 CopLINE_set(PL_curcop, oldline);
312caa8e
CS		 3158 if (paramList == PL_beginav)
3159 sv_catpv(atsv, "BEGIN failed--compilation aborted");
3160 else
4f25aa18
GS		 3161 Perl_sv_catpvf(aTHX_ atsv,
3162 "%s failed--call queue aborted",
3163 paramList == PL_stopav ? "STOP"
3164 : paramList == PL_initav ? "INIT"
3165 : "END");
312caa8e
CS		 3166 while (PL_scopestack_ix > oldscope)
3167 LEAVE;
971a9dd3 3168 Perl_croak(aTHX_ "%s", SvPVx(atsv, n_a));
a0d0e21e 3169 }
85e6fe83 3170 break;
6224f72b 3171 case 1:
f86702cc 3172 STATUS_ALL_FAILURE;
85e6fe83 3173 /* FALL THROUGH */
6224f72b 3174 case 2:
85e6fe83 3175 /* my_exit() was called */
3280af22 3176 while (PL_scopestack_ix > oldscope)
2ae324a7 3177 LEAVE;
84902520 3178 FREETMPS;
3280af22 3179 PL_curstash = PL_defstash;
3280af22 3180 PL_curcop = &PL_compiling;
57843af0 3181 CopLINE_set(PL_curcop, oldline);
cc3604b1 3182 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED)) {
3280af22 3183 if (paramList == PL_beginav)
cea2e8a9 3184 Perl_croak(aTHX_ "BEGIN failed--compilation aborted");
85e6fe83 3185 else
4f25aa18
GS		 3186 Perl_croak(aTHX_ "%s failed--call queue aborted",
3187 paramList == PL_stopav ? "STOP"
3188 : paramList == PL_initav ? "INIT"
3189 : "END");
85e6fe83 3190 }
f86702cc 3191 my_exit_jump();
85e6fe83 3192 /* NOTREACHED */
6224f72b 3193 case 3:
312caa8e
CS		 3194 if (PL_restartop) {
3195 PL_curcop = &PL_compiling;
57843af0 3196 CopLINE_set(PL_curcop, oldline);
312caa8e 3197 JMPENV_JUMP(3);
85e6fe83 3198 }
bf49b057 3199 PerlIO_printf(Perl_error_log, "panic: restartop\n");
312caa8e
CS		 3200 FREETMPS;
3201 break;
8990e307 3202 }
93a17b20 3203 }
93a17b20 3204}
93a17b20 3205
312caa8e 3206STATIC void *
cea2e8a9 3207S_call_list_body(pTHX_ va_list args)
312caa8e
CS		 3208{
3209 dTHR;
3210 CV *cv = va_arg(args, CV*);
3211
3212 PUSHMARK(PL_stack_sp);
864dbfa3 3213 call_sv((SV*)cv, G_EVAL|G_DISCARD);
312caa8e
CS		 3214 return NULL;
3215}
3216
f86702cc 3217void
864dbfa3 3218Perl_my_exit(pTHX_ U32 status)
f86702cc 3219{
5dc0d613
MB		 3220 dTHR;
3221
8b73bbec 3222 DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
a863c7d1 3223 thr, (unsigned long) status));
f86702cc 3224 switch (status) {
3225 case 0:
3226 STATUS_ALL_SUCCESS;
3227 break;
3228 case 1:
3229 STATUS_ALL_FAILURE;
3230 break;
3231 default:
3232 STATUS_NATIVE_SET(status);
3233 break;
3234 }
3235 my_exit_jump();
3236}
3237
3238void
864dbfa3 3239Perl_my_failure_exit(pTHX)
f86702cc 3240{
3241#ifdef VMS
3242 if (vaxc$errno & 1) {
4fdae800 3243 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
3244 STATUS_NATIVE_SET(44);
f86702cc 3245 }
3246 else {
ff0cee69 3247 if (!vaxc$errno && errno) /* unlikely */
4fdae800 3248 STATUS_NATIVE_SET(44);
f86702cc 3249 else
4fdae800 3250 STATUS_NATIVE_SET(vaxc$errno);
f86702cc 3251 }
3252#else
9b599b2a 3253 int exitstatus;
f86702cc 3254 if (errno & 255)
3255 STATUS_POSIX_SET(errno);
9b599b2a
GS		 3256 else {
3257 exitstatus = STATUS_POSIX >> 8;
3258 if (exitstatus & 255)
3259 STATUS_POSIX_SET(exitstatus);
3260 else
3261 STATUS_POSIX_SET(255);
3262 }
f86702cc 3263#endif
3264 my_exit_jump();
93a17b20
LW		 3265}
3266
76e3520e 3267STATIC void
cea2e8a9 3268S_my_exit_jump(pTHX)
f86702cc 3269{
de616352 3270 dTHR;
c09156bb 3271 register PERL_CONTEXT *cx;
f86702cc 3272 I32 gimme;
3273 SV **newsp;
3274
3280af22
NIS		 3275 if (PL_e_script) {
3276 SvREFCNT_dec(PL_e_script);
3277 PL_e_script = Nullsv;
f86702cc 3278 }
3279
3280af22 3280 POPSTACK_TO(PL_mainstack);
f86702cc 3281 if (cxstack_ix >= 0) {
3282 if (cxstack_ix > 0)
3283 dounwind(0);
3280af22 3284 POPBLOCK(cx,PL_curpm);
f86702cc 3285 LEAVE;
3286 }
ff0cee69 3287
6224f72b 3288 JMPENV_JUMP(2);
f86702cc 3289}
873ef191 3290
7a5f8e82 3291#ifdef PERL_OBJECT
873ef191 3292#include "XSUB.h"
51371543 3293#endif
873ef191 3294
0cb96387
GS		 3295static I32
3296read_e_script(pTHXo_ int idx, SV *buf_sv, int maxlen)
873ef191
GS		 3297{
3298 char *p, *nl;
3280af22 3299 p = SvPVX(PL_e_script);
873ef191 3300 nl = strchr(p, '\n');
3280af22 3301 nl = (nl) ? nl+1 : SvEND(PL_e_script);
7dfe3f66 3302 if (nl-p == 0) {
0cb96387 3303 filter_del(read_e_script);
873ef191 3304 return 0;
7dfe3f66 3305 }
873ef191 3306 sv_catpvn(buf_sv, p, nl-p);
3280af22 3307 sv_chop(PL_e_script, nl);
873ef191
GS		 3308 return 1;
3309}
Unnamed repository; edit this file 'description' to name the repository.