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