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