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