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