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