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