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