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