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