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