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