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