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