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