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