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