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