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
improvements for high-bit text literals (from Gisle Aas)
[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
baed7233
DL		 2169#ifdef BINARY_BUILD_NOTICE
2170 BINARY_BUILD_NOTICE;
2171#endif
760ac839 2172 printf("\n\
79072805 2173Perl may be copied only under the terms of either the Artistic License or the\n\
95103687
GS		 2174GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n\
2175Complete documentation for Perl, including FAQ lists, should be found on\n\
2176this system using `man perl' or `perldoc perl'. If you have access to the\n\
2177Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n");
6ad3d225 2178 PerlProc_exit(0);
79072805 2179 case 'w':
599cee73
PM		 2180 if (! (PL_dowarn & G_WARN_ALL_MASK))
2181 PL_dowarn |= G_WARN_ON;
2182 s++;
2183 return s;
2184 case 'W':
2185 PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
e24b16f9 2186 PL_compiling.cop_warnings = WARN_ALL ;
599cee73
PM		 2187 s++;
2188 return s;
2189 case 'X':
2190 PL_dowarn = G_WARN_ALL_OFF;
e24b16f9 2191 PL_compiling.cop_warnings = WARN_NONE ;
79072805
LW		 2192 s++;
2193 return s;
a0d0e21e 2194 case '*':
79072805
LW		 2195 case ' ':
2196 if (s[1] == '-') /* Additional switches on #! line. */
2197 return s+2;
2198 break;
a0d0e21e 2199 case '-':
79072805 2200 case 0:
51882d45 2201#if defined(WIN32) || !defined(PERL_STRICT_CR)
a868473f
NIS		 2202 case '\r':
2203#endif
79072805
LW		 2204 case '\n':
2205 case '\t':
2206 break;
aa689395 2207#ifdef ALTERNATE_SHEBANG
2208 case 'S': /* OS/2 needs -S on "extproc" line. */
2209 break;
2210#endif
a0d0e21e 2211 case 'P':
3280af22 2212 if (PL_preprocess)
a0d0e21e
LW		 2213 return s+1;
2214 /* FALL THROUGH */
79072805 2215 default:
cea2e8a9 2216 Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
79072805
LW		 2217 }
2218 return Nullch;
2219}
2220
2221/* compliments of Tom Christiansen */
2222
2223/* unexec() can be found in the Gnu emacs distribution */
ee580363 2224/* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
79072805
LW		 2225
2226void
864dbfa3 2227Perl_my_unexec(pTHX)
79072805
LW		 2228{
2229#ifdef UNEXEC
46fc3d4c 2230 SV* prog;
2231 SV* file;
ee580363 2232 int status = 1;
79072805
LW		 2233 extern int etext;
2234
ee580363 2235 prog = newSVpv(BIN_EXP, 0);
46fc3d4c 2236 sv_catpv(prog, "/perl");
6b88bc9c 2237 file = newSVpv(PL_origfilename, 0);
46fc3d4c 2238 sv_catpv(file, ".perldump");
79072805 2239
ee580363
GS		 2240 unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
2241 /* unexec prints msg to stderr in case of failure */
6ad3d225 2242 PerlProc_exit(status);
79072805 2243#else
a5f75d66
AD		 2244# ifdef VMS
2245# include <lib$routines.h>
2246 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
aa689395 2247# else
79072805 2248 ABORT(); /* for use with undump */
aa689395 2249# endif
a5f75d66 2250#endif
79072805
LW		 2251}
2252
cb68f92d
GS		 2253/* initialize curinterp */
2254STATIC void
cea2e8a9 2255S_init_interp(pTHX)
cb68f92d
GS		 2256{
2257
066ef5b5 2258#ifdef PERL_OBJECT /* XXX kludge */
cb68f92d 2259#define I_REINIT \
6b88bc9c
GS		 2260 STMT_START { \
2261 PL_chopset = " \n-"; \
2262 PL_copline = NOLINE; \
2263 PL_curcop = &PL_compiling;\
2264 PL_curcopdb = NULL; \
2265 PL_dbargs = 0; \
3967c732 2266 PL_dumpindent = 4; \
6b88bc9c
GS		 2267 PL_laststatval = -1; \
2268 PL_laststype = OP_STAT; \
2269 PL_maxscream = -1; \
2270 PL_maxsysfd = MAXSYSFD; \
2271 PL_statname = Nullsv; \
2272 PL_tmps_floor = -1; \
2273 PL_tmps_ix = -1; \
2274 PL_op_mask = NULL; \
6b88bc9c
GS		 2275 PL_laststatval = -1; \
2276 PL_laststype = OP_STAT; \
2277 PL_mess_sv = Nullsv; \
2278 PL_splitstr = " "; \
2279 PL_generation = 100; \
2280 PL_exitlist = NULL; \
2281 PL_exitlistlen = 0; \
2282 PL_regindent = 0; \
2283 PL_in_clean_objs = FALSE; \
2284 PL_in_clean_all = FALSE; \
2285 PL_profiledata = NULL; \
2286 PL_rsfp = Nullfp; \
2287 PL_rsfp_filters = Nullav; \
24d3c518 2288 PL_dirty = FALSE; \
cb68f92d 2289 } STMT_END
9666903d 2290 I_REINIT;
066ef5b5
GS		 2291#else
2292# ifdef MULTIPLICITY
2293# define PERLVAR(var,type)
51371543 2294# define PERLVARA(var,n,type)
cea2e8a9 2295# if defined(PERL_IMPLICIT_CONTEXT)
54aff467
GS		 2296# if defined(USE_THREADS)
2297# define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
2298# define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
2299# else /* !USE_THREADS */
2300# define PERLVARI(var,type,init) aTHX->var = init;
2301# define PERLVARIC(var,type,init) aTHX->var = init;
2302# endif /* USE_THREADS */
cea2e8a9 2303# else
c5be433b
GS		 2304# define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
2305# define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
cea2e8a9 2306# endif
066ef5b5
GS		 2307# include "intrpvar.h"
2308# ifndef USE_THREADS
2309# include "thrdvar.h"
2310# endif
2311# undef PERLVAR
51371543 2312# undef PERLVARA
066ef5b5
GS		 2313# undef PERLVARI
2314# undef PERLVARIC
3967c732 2315# else
066ef5b5 2316# define PERLVAR(var,type)
51371543 2317# define PERLVARA(var,n,type)
533c011a
NIS		 2318# define PERLVARI(var,type,init) PL_##var = init;
2319# define PERLVARIC(var,type,init) PL_##var = init;
066ef5b5
GS		 2320# include "intrpvar.h"
2321# ifndef USE_THREADS
2322# include "thrdvar.h"
2323# endif
2324# undef PERLVAR
51371543 2325# undef PERLVARA
066ef5b5
GS		 2326# undef PERLVARI
2327# undef PERLVARIC
2328# endif
cb68f92d
GS		 2329#endif
2330
cb68f92d
GS		 2331}
2332
76e3520e 2333STATIC void
cea2e8a9 2334S_init_main_stash(pTHX)
79072805 2335{
11343788 2336 dTHR;
463ee0b2 2337 GV *gv;
6e72f9df 2338
2339 /* Note that strtab is a rather special HV. Assumptions are made
2340 about not iterating on it, and not adding tie magic to it.
2341 It is properly deallocated in perl_destruct() */
3280af22 2342 PL_strtab = newHV();
5f08fbcd
GS		 2343#ifdef USE_THREADS
2344 MUTEX_INIT(&PL_strtab_mutex);
2345#endif
3280af22
NIS		 2346 HvSHAREKEYS_off(PL_strtab); /* mandatory */
2347 hv_ksplit(PL_strtab, 512);
6e72f9df 2348
3280af22 2349 PL_curstash = PL_defstash = newHV();
79cb57f6 2350 PL_curstname = newSVpvn("main",4);
adbc6bb1
LW		 2351 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
2352 SvREFCNT_dec(GvHV(gv));
3280af22 2353 GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);
463ee0b2 2354 SvREADONLY_on(gv);
3280af22
NIS		 2355 HvNAME(PL_defstash) = savepv("main");
2356 PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
2357 GvMULTI_on(PL_incgv);
2358 PL_hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */
2359 GvMULTI_on(PL_hintgv);
2360 PL_defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
2361 PL_errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
2362 GvMULTI_on(PL_errgv);
2363 PL_replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */
2364 GvMULTI_on(PL_replgv);
cea2e8a9 2365 (void)Perl_form(aTHX_ "%240s",""); /* Preallocate temp - for immediate signals. */
38a03e6e
MB		 2366 sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
2367 sv_setpvn(ERRSV, "", 0);
3280af22 2368 PL_curstash = PL_defstash;
11faa288 2369 CopSTASH_set(&PL_compiling, PL_defstash);
ed094faf 2370 PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
3280af22 2371 PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
4633a7c4 2372 /* We must init $/ before switches are processed. */
864dbfa3 2373 sv_setpvn(get_sv("/", TRUE), "\n", 1);
79072805
LW		 2374}
2375
76e3520e 2376STATIC void
cea2e8a9 2377S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript)
79072805 2378{
0f15f207 2379 dTHR;
79072805 2380 register char *s;
2a92aaa0 2381
6c4ab083 2382 *fdscript = -1;
79072805 2383
3280af22
NIS		 2384 if (PL_e_script) {
2385 PL_origfilename = savepv("-e");
96436eeb 2386 }
6c4ab083
GS		 2387 else {
2388 /* if find_script() returns, it returns a malloc()-ed value */
3280af22 2389 PL_origfilename = scriptname = find_script(scriptname, dosearch, NULL, 1);
6c4ab083
GS		 2390
2391 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
2392 char *s = scriptname + 8;
2393 *fdscript = atoi(s);
2394 while (isDIGIT(*s))
2395 s++;
2396 if (*s) {
2397 scriptname = savepv(s + 1);
3280af22
NIS		 2398 Safefree(PL_origfilename);
2399 PL_origfilename = scriptname;
6c4ab083
GS		 2400 }
2401 }
2402 }
2403
57843af0 2404 CopFILE_set(PL_curcop, PL_origfilename);
3280af22 2405 if (strEQ(PL_origfilename,"-"))
79072805 2406 scriptname = "";
01f988be 2407 if (*fdscript >= 0) {
3280af22 2408 PL_rsfp = PerlIO_fdopen(*fdscript,PERL_SCRIPT_MODE);
96436eeb 2409#if defined(HAS_FCNTL) && defined(F_SETFD)
3280af22
NIS		 2410 if (PL_rsfp)
2411 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1); /* ensure close-on-exec */
96436eeb 2412#endif
2413 }
3280af22 2414 else if (PL_preprocess) {
46fc3d4c 2415 char *cpp_cfg = CPPSTDIN;
79cb57f6 2416 SV *cpp = newSVpvn("",0);
46fc3d4c 2417 SV *cmd = NEWSV(0,0);
2418
2419 if (strEQ(cpp_cfg, "cppstdin"))
cea2e8a9 2420 Perl_sv_catpvf(aTHX_ cpp, "%s/", BIN_EXP);
46fc3d4c 2421 sv_catpv(cpp, cpp_cfg);
79072805 2422
0df16ed7 2423 sv_catpvn(sv, "-I", 2);
fed7345c 2424 sv_catpv(sv,PRIVLIB_EXP);
46fc3d4c 2425
79072805 2426#ifdef MSDOS
cea2e8a9 2427 Perl_sv_setpvf(aTHX_ cmd, "\
79072805
LW		 2428sed %s -e \"/^[^#]/b\" \
2429 -e \"/^#[ ]*include[ ]/b\" \
2430 -e \"/^#[ ]*define[ ]/b\" \
2431 -e \"/^#[ ]*if[ ]/b\" \
2432 -e \"/^#[ ]*ifdef[ ]/b\" \
2433 -e \"/^#[ ]*ifndef[ ]/b\" \
2434 -e \"/^#[ ]*else/b\" \
2435 -e \"/^#[ ]*elif[ ]/b\" \
2436 -e \"/^#[ ]*undef[ ]/b\" \
2437 -e \"/^#[ ]*endif/b\" \
2438 -e \"s/^#.*//\" \
894356b3 2439 %s | %"SVf" -C %"SVf" %s",
6b88bc9c 2440 (PL_doextract ? "-e \"1,/^#/d\n\"" : ""),
79072805 2441#else
092bebab 2442# ifdef __OPEN_VM
cea2e8a9 2443 Perl_sv_setpvf(aTHX_ cmd, "\
092bebab
JH		 2444%s %s -e '/^[^#]/b' \
2445 -e '/^#[ ]*include[ ]/b' \
2446 -e '/^#[ ]*define[ ]/b' \
2447 -e '/^#[ ]*if[ ]/b' \
2448 -e '/^#[ ]*ifdef[ ]/b' \
2449 -e '/^#[ ]*ifndef[ ]/b' \
2450 -e '/^#[ ]*else/b' \
2451 -e '/^#[ ]*elif[ ]/b' \
2452 -e '/^#[ ]*undef[ ]/b' \
2453 -e '/^#[ ]*endif/b' \
2454 -e 's/^[ ]*#.*//' \
894356b3 2455 %s | %"SVf" %"SVf" %s",
092bebab 2456# else
cea2e8a9 2457 Perl_sv_setpvf(aTHX_ cmd, "\
79072805
LW		 2458%s %s -e '/^[^#]/b' \
2459 -e '/^#[ ]*include[ ]/b' \
2460 -e '/^#[ ]*define[ ]/b' \
2461 -e '/^#[ ]*if[ ]/b' \
2462 -e '/^#[ ]*ifdef[ ]/b' \
2463 -e '/^#[ ]*ifndef[ ]/b' \
2464 -e '/^#[ ]*else/b' \
2465 -e '/^#[ ]*elif[ ]/b' \
2466 -e '/^#[ ]*undef[ ]/b' \
2467 -e '/^#[ ]*endif/b' \
2468 -e 's/^[ ]*#.*//' \
894356b3 2469 %s | %"SVf" -C %"SVf" %s",
092bebab 2470# endif
79072805
LW		 2471#ifdef LOC_SED
2472 LOC_SED,
2473#else
2474 "sed",
2475#endif
3280af22 2476 (PL_doextract ? "-e '1,/^#/d\n'" : ""),
79072805 2477#endif
46fc3d4c 2478 scriptname, cpp, sv, CPPMINUS);
3280af22 2479 PL_doextract = FALSE;
79072805 2480#ifdef IAMSUID /* actually, this is caught earlier */
b28d0864 2481 if (PL_euid != PL_uid && !PL_euid) { /* if running suidperl */
79072805 2482#ifdef HAS_SETEUID
b28d0864 2483 (void)seteuid(PL_uid); /* musn't stay setuid root */
79072805
LW		 2484#else
2485#ifdef HAS_SETREUID
b28d0864 2486 (void)setreuid((Uid_t)-1, PL_uid);
85e6fe83
LW		 2487#else
2488#ifdef HAS_SETRESUID
b28d0864 2489 (void)setresuid((Uid_t)-1, PL_uid, (Uid_t)-1);
79072805 2490#else
b28d0864 2491 PerlProc_setuid(PL_uid);
79072805
LW		 2492#endif
2493#endif
85e6fe83 2494#endif
b28d0864 2495 if (PerlProc_geteuid() != PL_uid)
cea2e8a9 2496 Perl_croak(aTHX_ "Can't do seteuid!\n");
79072805
LW		 2497 }
2498#endif /* IAMSUID */
3280af22 2499 PL_rsfp = PerlProc_popen(SvPVX(cmd), "r");
46fc3d4c 2500 SvREFCNT_dec(cmd);
2501 SvREFCNT_dec(cpp);
79072805
LW		 2502 }
2503 else if (!*scriptname) {
bbce6d69 2504 forbid_setid("program input from stdin");
3280af22 2505 PL_rsfp = PerlIO_stdin();
79072805 2506 }
96436eeb 2507 else {
3280af22 2508 PL_rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
96436eeb 2509#if defined(HAS_FCNTL) && defined(F_SETFD)
3280af22
NIS		 2510 if (PL_rsfp)
2511 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1); /* ensure close-on-exec */
96436eeb 2512#endif
2513 }
3280af22 2514 if (!PL_rsfp) {
13281fa4 2515#ifdef DOSUID
a687059c 2516#ifndef IAMSUID /* in case script is not readable before setuid */
6b88bc9c 2517 if (PL_euid &&
cc49e20b 2518 PerlLIO_stat(CopFILE(PL_curcop),&PL_statbuf) >= 0 &&
6b88bc9c
GS		 2519 PL_statbuf.st_mode & (S_ISUID|S_ISGID))
2520 {
46fc3d4c 2521 /* try again */
a7cb1f99 2522 PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, BIN_EXP,
273cf8d1
GS		 2523 (int)PERL_REVISION, (int)PERL_VERSION,
2524 (int)PERL_SUBVERSION), PL_origargv);
cea2e8a9 2525 Perl_croak(aTHX_ "Can't do setuid\n");
13281fa4
LW		 2526 }
2527#endif
2528#endif
cea2e8a9 2529 Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
cc49e20b 2530 CopFILE(PL_curcop), Strerror(errno));
13281fa4 2531 }
79072805 2532}
8d063cd8 2533
7b89560d
JH		 2534/* Mention
2535 * I_SYSSTATVFS HAS_FSTATVFS
2536 * I_SYSMOUNT
2537 * I_STATFS HAS_FSTATFS
2538 * I_MNTENT HAS_GETMNTENT HAS_HASMNTOPT
2539 * here so that metaconfig picks them up. */
2540
104d25b7 2541#ifdef IAMSUID
864dbfa3 2542STATIC int
e688b231 2543S_fd_on_nosuid_fs(pTHX_ int fd)
104d25b7 2544{
0545a864
JH		 2545 int check_okay = 0; /* able to do all the required sys/libcalls */
2546 int on_nosuid = 0; /* the fd is on a nosuid fs */
104d25b7 2547/*
ad27e871 2548 * Preferred order: fstatvfs(), fstatfs(), ustat()+getmnt(), getmntent().
e688b231 2549 * fstatvfs() is UNIX98.
0545a864 2550 * fstatfs() is 4.3 BSD.
ad27e871 2551 * ustat()+getmnt() is pre-4.3 BSD.
0545a864
JH		 2552 * getmntent() is O(number-of-mounted-filesystems) and can hang on
2553 * an irrelevant filesystem while trying to reach the right one.
104d25b7
JH		 2554 */
2555
2556# ifdef HAS_FSTATVFS
2557 struct statvfs stfs;
2558 check_okay = fstatvfs(fd, &stfs) == 0;
2559 on_nosuid = check_okay && (stfs.f_flag & ST_NOSUID);
2560# else
0545a864 2561# ifdef PERL_MOUNT_NOSUID
ad27e871
JH		 2562# if defined(HAS_FSTATFS) && \
2563 defined(HAS_STRUCT_STATFS) && \
2564 defined(HAS_STRUCT_STATFS_F_FLAGS)
e688b231 2565 struct statfs stfs;
104d25b7 2566 check_okay = fstatfs(fd, &stfs) == 0;
104d25b7 2567 on_nosuid = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID);
0545a864
JH		 2568# else
2569# if defined(HAS_FSTAT) && \
2570 defined(HAS_USTAT) && \
ad27e871 2571 defined(HAS_GETMNT) && \
65d1664e 2572 defined(HAS_STRUCT_FS_DATA) && \
ad27e871 2573 defined(NOSTAT_ONE)
0545a864
JH		 2574 struct stat fdst;
2575 if (fstat(fd, &fdst) == 0) {
2576 struct ustat us;
2577 if (ustat(fdst.st_dev, &us) == 0) {
2578 struct fs_data fsd;
ad27e871
JH		 2579 /* NOSTAT_ONE here because we're not examining fields which
2580 * vary between that case and STAT_ONE. */
2581 if (getmnt((int*)0, &fsd, (int)0, NOSTAT_ONE, us.f_fname) == 0) {
0545a864
JH		 2582 size_t cmplen = sizeof(us.f_fname);
2583 if (sizeof(fsd.fd_req.path) < cmplen)
2584 cmplen = sizeof(fsd.fd_req.path);
2585 if (strnEQ(fsd.fd_req.path, us.f_fname, cmplen) &&
2586 fdst.st_dev == fsd.fd_req.dev) {
2587 check_okay = 1;
2588 on_nosuid = fsd.fd_req.flags & PERL_MOUNT_NOSUID;
2589 }
2590 }
2591 }
2592 }
2593 }
ad27e871
JH		 2594# endif /* fstat+ustat+getmnt */
2595# endif /* fstatfs */
104d25b7 2596# else
0545a864
JH		 2597# if defined(HAS_GETMNTENT) && \
2598 defined(HAS_HASMNTOPT) && \
2599 defined(MNTOPT_NOSUID)
104d25b7
JH		 2600 FILE *mtab = fopen("/etc/mtab", "r");
2601 struct mntent *entry;
2602 struct stat stb, fsb;
2603
2604 if (mtab && (fstat(fd, &stb) == 0)) {
e688b231
JH		 2605 while (entry = getmntent(mtab)) {
2606 if (stat(entry->mnt_dir, &fsb) == 0
2607 && fsb.st_dev == stb.st_dev)
104d25b7
JH		 2608 {
2609 /* found the filesystem */
2610 check_okay = 1;
2611 if (hasmntopt(entry, MNTOPT_NOSUID))
2612 on_nosuid = 1;
2613 break;
e688b231 2614 } /* A single fs may well fail its stat(). */
104d25b7
JH		 2615 }
2616 }
2617 if (mtab)
2618 fclose(mtab);
ad27e871 2619# endif /* getmntent+hasmntopt */
0545a864 2620# endif /* PERL_MOUNT_NOSUID: fstatfs or fstat+ustat+statfs */
e688b231 2621# endif /* statvfs */
0545a864 2622
104d25b7 2623 if (!check_okay)
0545a864 2624 Perl_croak(aTHX_ "Can't check filesystem of script \"%s\" for nosuid", PL_origfilename);
104d25b7
JH		 2625 return on_nosuid;
2626}
2627#endif /* IAMSUID */
2628
76e3520e 2629STATIC void
cea2e8a9 2630S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript)
79072805 2631{
96436eeb 2632 int which;
2633
13281fa4
LW		 2634 /* do we need to emulate setuid on scripts? */
2635
2636 /* This code is for those BSD systems that have setuid #! scripts disabled
2637 * in the kernel because of a security problem. Merely defining DOSUID
2638 * in perl will not fix that problem, but if you have disabled setuid
2639 * scripts in the kernel, this will attempt to emulate setuid and setgid
2640 * on scripts that have those now-otherwise-useless bits set. The setuid
27e2fb84
LW		 2641 * root version must be called suidperl or sperlN.NNN. If regular perl
2642 * discovers that it has opened a setuid script, it calls suidperl with
2643 * the same argv that it had. If suidperl finds that the script it has
2644 * just opened is NOT setuid root, it sets the effective uid back to the
2645 * uid. We don't just make perl setuid root because that loses the
2646 * effective uid we had before invoking perl, if it was different from the
2647 * uid.
13281fa4
LW		 2648 *
2649 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
2650 * be defined in suidperl only. suidperl must be setuid root. The
2651 * Configure script will set this up for you if you want it.
2652 */
a687059c 2653
13281fa4 2654#ifdef DOSUID
ea0efc06 2655 dTHR;
6e72f9df 2656 char *s, *s2;
a0d0e21e 2657
b28d0864 2658 if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0) /* normal stat is insecure */
cea2e8a9 2659 Perl_croak(aTHX_ "Can't stat script \"%s\"",PL_origfilename);
b28d0864 2660 if (fdscript < 0 && PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
79072805 2661 I32 len;
2d8e6c8d 2662 STRLEN n_a;
13281fa4 2663
a687059c 2664#ifdef IAMSUID
fe14fcc3 2665#ifndef HAS_SETREUID
a687059c
LW		 2666 /* On this access check to make sure the directories are readable,
2667 * there is actually a small window that the user could use to make
2668 * filename point to an accessible directory. So there is a faint
2669 * chance that someone could execute a setuid script down in a
2670 * non-accessible directory. I don't know what to do about that.
2671 * But I don't think it's too important. The manual lies when
2672 * it says access() is useful in setuid programs.
2673 */
cc49e20b 2674 if (PerlLIO_access(CopFILE(PL_curcop),1)) /*double check*/
cea2e8a9 2675 Perl_croak(aTHX_ "Permission denied");
a687059c
LW		 2676#else
2677 /* If we can swap euid and uid, then we can determine access rights
2678 * with a simple stat of the file, and then compare device and
2679 * inode to make sure we did stat() on the same file we opened.
2680 * Then we just have to make sure he or she can execute it.
2681 */
2682 {
2683 struct stat tmpstatbuf;
2684
85e6fe83
LW		 2685 if (
2686#ifdef HAS_SETREUID
b28d0864 2687 setreuid(PL_euid,PL_uid) < 0
a0d0e21e
LW		 2688#else
2689# if HAS_SETRESUID
b28d0864 2690 setresuid(PL_euid,PL_uid,(Uid_t)-1) < 0
a0d0e21e 2691# endif
85e6fe83 2692#endif
b28d0864 2693 || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
cea2e8a9 2694 Perl_croak(aTHX_ "Can't swap uid and euid"); /* really paranoid */
cc49e20b 2695 if (PerlLIO_stat(CopFILE(PL_curcop),&tmpstatbuf) < 0)
cea2e8a9 2696 Perl_croak(aTHX_ "Permission denied"); /* testing full pathname here */
2bb3463c 2697#if defined(IAMSUID) && !defined(NO_NOSUID_CHECK)
e688b231 2698 if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp)))
cea2e8a9 2699 Perl_croak(aTHX_ "Permission denied");
104d25b7 2700#endif
b28d0864
NIS		 2701 if (tmpstatbuf.st_dev != PL_statbuf.st_dev ||
2702 tmpstatbuf.st_ino != PL_statbuf.st_ino) {
2703 (void)PerlIO_close(PL_rsfp);
2704 if (PL_rsfp = PerlProc_popen("/bin/mail root","w")) { /* heh, heh */
2705 PerlIO_printf(PL_rsfp,
785fb66b
JH		 2706"User %"Uid_t_f" tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
2707(Filename of set-id script was %s, uid %"Uid_t_f" gid %"Gid_t_f".)\n\nSincerely,\nperl\n",
2708 PL_uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
b28d0864 2709 (long)PL_statbuf.st_dev, (long)PL_statbuf.st_ino,
cc49e20b 2710 CopFILE(PL_curcop),
785fb66b 2711 PL_statbuf.st_uid, PL_statbuf.st_gid);
b28d0864 2712 (void)PerlProc_pclose(PL_rsfp);
a687059c 2713 }
cea2e8a9 2714 Perl_croak(aTHX_ "Permission denied\n");
a687059c 2715 }
85e6fe83
LW		 2716 if (
2717#ifdef HAS_SETREUID
b28d0864 2718 setreuid(PL_uid,PL_euid) < 0
a0d0e21e
LW		 2719#else
2720# if defined(HAS_SETRESUID)
b28d0864 2721 setresuid(PL_uid,PL_euid,(Uid_t)-1) < 0
a0d0e21e 2722# endif
85e6fe83 2723#endif
b28d0864 2724 || PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid)
cea2e8a9 2725 Perl_croak(aTHX_ "Can't reswap uid and euid");
b28d0864 2726 if (!cando(S_IXUSR,FALSE,&PL_statbuf)) /* can real uid exec? */
cea2e8a9 2727 Perl_croak(aTHX_ "Permission denied\n");
a687059c 2728 }
fe14fcc3 2729#endif /* HAS_SETREUID */
a687059c
LW		 2730#endif /* IAMSUID */
2731
b28d0864 2732 if (!S_ISREG(PL_statbuf.st_mode))
cea2e8a9 2733 Perl_croak(aTHX_ "Permission denied");
b28d0864 2734 if (PL_statbuf.st_mode & S_IWOTH)
cea2e8a9 2735 Perl_croak(aTHX_ "Setuid/gid script is writable by world");
6b88bc9c 2736 PL_doswitches = FALSE; /* -s is insecure in suid */
57843af0 2737 CopLINE_inc(PL_curcop);
6b88bc9c 2738 if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch ||
2d8e6c8d 2739 strnNE(SvPV(PL_linestr,n_a),"#!",2) ) /* required even on Sys V */
cea2e8a9 2740 Perl_croak(aTHX_ "No #! line");
2d8e6c8d 2741 s = SvPV(PL_linestr,n_a)+2;
663a0e37 2742 if (*s == ' ') s++;
45d8adaa 2743 while (!isSPACE(*s)) s++;
2d8e6c8d 2744 for (s2 = s; (s2 > SvPV(PL_linestr,n_a)+2 &&
6e72f9df 2745 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
2746 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
cea2e8a9 2747 Perl_croak(aTHX_ "Not a perl script");
a687059c 2748 while (*s == ' ' || *s == '\t') s++;
13281fa4
LW		 2749 /*
2750 * #! arg must be what we saw above. They can invoke it by
2751 * mentioning suidperl explicitly, but they may not add any strange
2752 * arguments beyond what #! says if they do invoke suidperl that way.
2753 */
2754 len = strlen(validarg);
2755 if (strEQ(validarg," PHOOEY ") ||
45d8adaa 2756 strnNE(s,validarg,len) || !isSPACE(s[len]))
cea2e8a9 2757 Perl_croak(aTHX_ "Args must match #! line");
a687059c
LW		 2758
2759#ifndef IAMSUID
b28d0864
NIS		 2760 if (PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
2761 PL_euid == PL_statbuf.st_uid)
2762 if (!PL_do_undump)
cea2e8a9 2763 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
a687059c
LW		 2764FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2765#endif /* IAMSUID */
13281fa4 2766
b28d0864
NIS		 2767 if (PL_euid) { /* oops, we're not the setuid root perl */
2768 (void)PerlIO_close(PL_rsfp);
13281fa4 2769#ifndef IAMSUID
46fc3d4c 2770 /* try again */
a7cb1f99 2771 PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, BIN_EXP,
273cf8d1
GS		 2772 (int)PERL_REVISION, (int)PERL_VERSION,
2773 (int)PERL_SUBVERSION), PL_origargv);
13281fa4 2774#endif
cea2e8a9 2775 Perl_croak(aTHX_ "Can't do setuid\n");
13281fa4
LW		 2776 }
2777
b28d0864 2778 if (PL_statbuf.st_mode & S_ISGID && PL_statbuf.st_gid != PL_egid) {
fe14fcc3 2779#ifdef HAS_SETEGID
b28d0864 2780 (void)setegid(PL_statbuf.st_gid);
a687059c 2781#else
fe14fcc3 2782#ifdef HAS_SETREGID
b28d0864 2783 (void)setregid((Gid_t)-1,PL_statbuf.st_gid);
85e6fe83
LW		 2784#else
2785#ifdef HAS_SETRESGID
b28d0864 2786 (void)setresgid((Gid_t)-1,PL_statbuf.st_gid,(Gid_t)-1);
a687059c 2787#else
b28d0864 2788 PerlProc_setgid(PL_statbuf.st_gid);
a687059c
LW		 2789#endif
2790#endif
85e6fe83 2791#endif
b28d0864 2792 if (PerlProc_getegid() != PL_statbuf.st_gid)
cea2e8a9 2793 Perl_croak(aTHX_ "Can't do setegid!\n");
83025b21 2794 }
b28d0864
NIS		 2795 if (PL_statbuf.st_mode & S_ISUID) {
2796 if (PL_statbuf.st_uid != PL_euid)
fe14fcc3 2797#ifdef HAS_SETEUID
b28d0864 2798 (void)seteuid(PL_statbuf.st_uid); /* all that for this */
a687059c 2799#else
fe14fcc3 2800#ifdef HAS_SETREUID
b28d0864 2801 (void)setreuid((Uid_t)-1,PL_statbuf.st_uid);
85e6fe83
LW		 2802#else
2803#ifdef HAS_SETRESUID
b28d0864 2804 (void)setresuid((Uid_t)-1,PL_statbuf.st_uid,(Uid_t)-1);
a687059c 2805#else
b28d0864 2806 PerlProc_setuid(PL_statbuf.st_uid);
a687059c
LW		 2807#endif
2808#endif
85e6fe83 2809#endif
b28d0864 2810 if (PerlProc_geteuid() != PL_statbuf.st_uid)
cea2e8a9 2811 Perl_croak(aTHX_ "Can't do seteuid!\n");
a687059c 2812 }
b28d0864 2813 else if (PL_uid) { /* oops, mustn't run as root */
fe14fcc3 2814#ifdef HAS_SETEUID
b28d0864 2815 (void)seteuid((Uid_t)PL_uid);
a687059c 2816#else
fe14fcc3 2817#ifdef HAS_SETREUID
b28d0864 2818 (void)setreuid((Uid_t)-1,(Uid_t)PL_uid);
a687059c 2819#else
85e6fe83 2820#ifdef HAS_SETRESUID
b28d0864 2821 (void)setresuid((Uid_t)-1,(Uid_t)PL_uid,(Uid_t)-1);
85e6fe83 2822#else
b28d0864 2823 PerlProc_setuid((Uid_t)PL_uid);
85e6fe83 2824#endif
a687059c
LW		 2825#endif
2826#endif
b28d0864 2827 if (PerlProc_geteuid() != PL_uid)
cea2e8a9 2828 Perl_croak(aTHX_ "Can't do seteuid!\n");
83025b21 2829 }
748a9306 2830 init_ids();
b28d0864 2831 if (!cando(S_IXUSR,TRUE,&PL_statbuf))
cea2e8a9 2832 Perl_croak(aTHX_ "Permission denied\n"); /* they can't do this */
13281fa4
LW		 2833 }
2834#ifdef IAMSUID
6b88bc9c 2835 else if (PL_preprocess)
cea2e8a9 2836 Perl_croak(aTHX_ "-P not allowed for setuid/setgid script\n");
96436eeb 2837 else if (fdscript >= 0)
cea2e8a9 2838 Perl_croak(aTHX_ "fd script not allowed in suidperl\n");
13281fa4 2839 else
cea2e8a9 2840 Perl_croak(aTHX_ "Script is not setuid/setgid in suidperl\n");
96436eeb 2841
2842 /* We absolutely must clear out any saved ids here, so we */
2843 /* exec the real perl, substituting fd script for scriptname. */
2844 /* (We pass script name as "subdir" of fd, which perl will grok.) */
b28d0864
NIS		 2845 PerlIO_rewind(PL_rsfp);
2846 PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0); /* just in case rewind didn't */
6b88bc9c
GS		 2847 for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;
2848 if (!PL_origargv[which])
cea2e8a9
GS		 2849 Perl_croak(aTHX_ "Permission denied");
2850 PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s",
6b88bc9c 2851 PerlIO_fileno(PL_rsfp), PL_origargv[which]));
96436eeb 2852#if defined(HAS_FCNTL) && defined(F_SETFD)
b28d0864 2853 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0); /* ensure no close-on-exec */
96436eeb 2854#endif
a7cb1f99 2855 PerlProc_execv(Perl_form(aTHX_ "%s/perl"PERL_FS_VER_FMT, BIN_EXP,
273cf8d1
GS		 2856 (int)PERL_REVISION, (int)PERL_VERSION,
2857 (int)PERL_SUBVERSION), PL_origargv);/* try again */
cea2e8a9 2858 Perl_croak(aTHX_ "Can't do setuid\n");
13281fa4 2859#endif /* IAMSUID */
a687059c 2860#else /* !DOSUID */
3280af22 2861 if (PL_euid != PL_uid || PL_egid != PL_gid) { /* (suidperl doesn't exist, in fact) */
a687059c 2862#ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
96827780 2863 dTHR;
b28d0864
NIS		 2864 PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf); /* may be either wrapped or real suid */
2865 if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
a687059c 2866 ||
b28d0864 2867 (PL_egid != PL_gid && PL_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
a687059c 2868 )
b28d0864 2869 if (!PL_do_undump)
cea2e8a9 2870 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
a687059c
LW		 2871FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2872#endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
2873 /* not set-id, must be wrapped */
a687059c 2874 }
13281fa4 2875#endif /* DOSUID */
79072805 2876}
13281fa4 2877
76e3520e 2878STATIC void
cea2e8a9 2879S_find_beginning(pTHX)
79072805 2880{
6e72f9df 2881 register char *s, *s2;
33b78306
LW		 2882
2883 /* skip forward in input to the real script? */
2884
bbce6d69 2885 forbid_setid("-x");
3280af22
NIS		 2886 while (PL_doextract) {
2887 if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch)
cea2e8a9 2888 Perl_croak(aTHX_ "No Perl script found in input\n");
6e72f9df 2889 if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
3280af22
NIS		 2890 PerlIO_ungetc(PL_rsfp, '\n'); /* to keep line count right */
2891 PL_doextract = FALSE;
6e72f9df 2892 while (*s && !(isSPACE (*s) || *s == '#')) s++;
2893 s2 = s;
2894 while (*s == ' ' || *s == '\t') s++;
2895 if (*s++ == '-') {
2896 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2897 if (strnEQ(s2-4,"perl",4))
2898 /*SUPPRESS 530*/
2899 while (s = moreswitches(s)) ;
33b78306 2900 }
83025b21
LW		 2901 }
2902 }
2903}
2904
afe37c7d 2905
76e3520e 2906STATIC void
cea2e8a9 2907S_init_ids(pTHX)
352d5a3a 2908{
d8eceb89
JH		 2909 PL_uid = PerlProc_getuid();
2910 PL_euid = PerlProc_geteuid();
2911 PL_gid = PerlProc_getgid();
2912 PL_egid = PerlProc_getegid();
748a9306 2913#ifdef VMS
b28d0864
NIS		 2914 PL_uid |= PL_gid << 16;
2915 PL_euid |= PL_egid << 16;
748a9306 2916#endif
3280af22 2917 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
748a9306 2918}
79072805 2919
76e3520e 2920STATIC void
cea2e8a9 2921S_forbid_setid(pTHX_ char *s)
bbce6d69 2922{
3280af22 2923 if (PL_euid != PL_uid)
cea2e8a9 2924 Perl_croak(aTHX_ "No %s allowed while running setuid", s);
3280af22 2925 if (PL_egid != PL_gid)
cea2e8a9 2926 Perl_croak(aTHX_ "No %s allowed while running setgid", s);
bbce6d69 2927}
2928
1ee4443e
IZ		 2929void
2930Perl_init_debugger(pTHX)
748a9306 2931{
11343788 2932 dTHR;
1ee4443e
IZ		 2933 HV *ostash = PL_curstash;
2934
3280af22
NIS		 2935 PL_curstash = PL_debstash;
2936 PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2937 AvREAL_off(PL_dbargs);
2938 PL_DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2939 PL_DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2940 PL_DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
1ee4443e 2941 sv_upgrade(GvSV(PL_DBsub), SVt_IV); /* IVX accessed if PERLDB_SUB_NN */
3280af22
NIS		 2942 PL_DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2943 sv_setiv(PL_DBsingle, 0);
2944 PL_DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2945 sv_setiv(PL_DBtrace, 0);
2946 PL_DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2947 sv_setiv(PL_DBsignal, 0);
1ee4443e 2948 PL_curstash = ostash;
352d5a3a
LW		 2949}
2950
2ce36478
SM		 2951#ifndef STRESS_REALLOC
2952#define REASONABLE(size) (size)
2953#else
2954#define REASONABLE(size) (1) /* unreasonable */
2955#endif
2956
11343788 2957void
cea2e8a9 2958Perl_init_stacks(pTHX)
79072805 2959{
e336de0d 2960 /* start with 128-item stack and 8K cxstack */
3280af22 2961 PL_curstackinfo = new_stackinfo(REASONABLE(128),
e336de0d 2962 REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
3280af22
NIS		 2963 PL_curstackinfo->si_type = PERLSI_MAIN;
2964 PL_curstack = PL_curstackinfo->si_stack;
2965 PL_mainstack = PL_curstack; /* remember in case we switch stacks */
79072805 2966
3280af22
NIS		 2967 PL_stack_base = AvARRAY(PL_curstack);
2968 PL_stack_sp = PL_stack_base;
2969 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
8990e307 2970
3280af22
NIS		 2971 New(50,PL_tmps_stack,REASONABLE(128),SV*);
2972 PL_tmps_floor = -1;
2973 PL_tmps_ix = -1;
2974 PL_tmps_max = REASONABLE(128);
8990e307 2975
3280af22
NIS		 2976 New(54,PL_markstack,REASONABLE(32),I32);
2977 PL_markstack_ptr = PL_markstack;
2978 PL_markstack_max = PL_markstack + REASONABLE(32);
79072805 2979
ce2f7c3b 2980 SET_MARK_OFFSET;
e336de0d 2981
3280af22
NIS		 2982 New(54,PL_scopestack,REASONABLE(32),I32);
2983 PL_scopestack_ix = 0;
2984 PL_scopestack_max = REASONABLE(32);
79072805 2985
3280af22
NIS		 2986 New(54,PL_savestack,REASONABLE(128),ANY);
2987 PL_savestack_ix = 0;
2988 PL_savestack_max = REASONABLE(128);
79072805 2989
3280af22
NIS		 2990 New(54,PL_retstack,REASONABLE(16),OP*);
2991 PL_retstack_ix = 0;
2992 PL_retstack_max = REASONABLE(16);
378cc40b 2993}
33b78306 2994
2ce36478
SM		 2995#undef REASONABLE
2996
76e3520e 2997STATIC void
cea2e8a9 2998S_nuke_stacks(pTHX)
6e72f9df 2999{
e858de61 3000 dTHR;
3280af22
NIS		 3001 while (PL_curstackinfo->si_next)
3002 PL_curstackinfo = PL_curstackinfo->si_next;
3003 while (PL_curstackinfo) {
3004 PERL_SI *p = PL_curstackinfo->si_prev;
bac4b2ad 3005 /* curstackinfo->si_stack got nuked by sv_free_arenas() */
3280af22
NIS		 3006 Safefree(PL_curstackinfo->si_cxstack);
3007 Safefree(PL_curstackinfo);
3008 PL_curstackinfo = p;
e336de0d 3009 }
3280af22
NIS		 3010 Safefree(PL_tmps_stack);
3011 Safefree(PL_markstack);
3012 Safefree(PL_scopestack);
3013 Safefree(PL_savestack);
3014 Safefree(PL_retstack);
378cc40b 3015}
33b78306 3016
76e3520e 3017#ifndef PERL_OBJECT
760ac839 3018static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
76e3520e 3019#endif
7aa04957 3020
76e3520e 3021STATIC void
cea2e8a9 3022S_init_lexer(pTHX)
8990e307 3023{
76e3520e
GS		 3024#ifdef PERL_OBJECT
3025 PerlIO *tmpfp;
3026#endif
3280af22
NIS		 3027 tmpfp = PL_rsfp;
3028 PL_rsfp = Nullfp;
3029 lex_start(PL_linestr);
3030 PL_rsfp = tmpfp;
79cb57f6 3031 PL_subname = newSVpvn("main",4);
8990e307
LW		 3032}
3033
76e3520e 3034STATIC void
cea2e8a9 3035S_init_predump_symbols(pTHX)
45d8adaa 3036{
11343788 3037 dTHR;
93a17b20 3038 GV *tmpgv;
a0d0e21e 3039 GV *othergv;
af8c498a 3040 IO *io;
79072805 3041
864dbfa3 3042 sv_setpvn(get_sv("\"", TRUE), " ", 1);
3280af22
NIS		 3043 PL_stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
3044 GvMULTI_on(PL_stdingv);
af8c498a
GS		 3045 io = GvIOp(PL_stdingv);
3046 IoIFP(io) = PerlIO_stdin();
adbc6bb1 3047 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
a5f75d66 3048 GvMULTI_on(tmpgv);
af8c498a 3049 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
79072805 3050
85e6fe83 3051 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
a5f75d66 3052 GvMULTI_on(tmpgv);
af8c498a
GS		 3053 io = GvIOp(tmpgv);
3054 IoOFP(io) = IoIFP(io) = PerlIO_stdout();
4633a7c4 3055 setdefout(tmpgv);
adbc6bb1 3056 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
a5f75d66 3057 GvMULTI_on(tmpgv);
af8c498a 3058 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
79072805 3059
bf49b057
GS		 3060 PL_stderrgv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
3061 GvMULTI_on(PL_stderrgv);
3062 io = GvIOp(PL_stderrgv);
af8c498a 3063 IoOFP(io) = IoIFP(io) = PerlIO_stderr();
adbc6bb1 3064 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
a5f75d66 3065 GvMULTI_on(tmpgv);
af8c498a 3066 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
79072805 3067
3280af22 3068 PL_statname = NEWSV(66,0); /* last filename we did stat on */
ab821d7f 3069
3280af22
NIS		 3070 if (!PL_osname)
3071 PL_osname = savepv(OSNAME);
79072805 3072}
33b78306 3073
76e3520e 3074STATIC void
cea2e8a9 3075S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
33b78306 3076{
a863c7d1 3077 dTHR;
79072805
LW		 3078 char *s;
3079 SV *sv;
3080 GV* tmpgv;
fe14fcc3 3081
79072805 3082 argc--,argv++; /* skip name of script */
3280af22 3083 if (PL_doswitches) {
79072805
LW		 3084 for (; argc > 0 && **argv == '-'; argc--,argv++) {
3085 if (!argv[0][1])
3086 break;
379d538a 3087 if (argv[0][1] == '-' && !argv[0][2]) {
79072805
LW		 3088 argc--,argv++;
3089 break;
3090 }
93a17b20 3091 if (s = strchr(argv[0], '=')) {
79072805 3092 *s++ = '\0';
85e6fe83 3093 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
79072805
LW		 3094 }
3095 else
85e6fe83 3096 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
fe14fcc3 3097 }
79072805 3098 }
3280af22
NIS		 3099 PL_toptarget = NEWSV(0,0);
3100 sv_upgrade(PL_toptarget, SVt_PVFM);
3101 sv_setpvn(PL_toptarget, "", 0);
3102 PL_bodytarget = NEWSV(0,0);
3103 sv_upgrade(PL_bodytarget, SVt_PVFM);
3104 sv_setpvn(PL_bodytarget, "", 0);
3105 PL_formtarget = PL_bodytarget;
79072805 3106
bbce6d69 3107 TAINT;
85e6fe83 3108 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
3280af22 3109 sv_setpv(GvSV(tmpgv),PL_origfilename);
79072805
LW		 3110 magicname("0", "0", 1);
3111 }
85e6fe83 3112 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
ed344e4f
IZ		 3113#ifdef OS2
3114 sv_setpv(GvSV(tmpgv), os2_execname());
3115#else
3280af22 3116 sv_setpv(GvSV(tmpgv),PL_origargv[0]);
ed344e4f 3117#endif
3280af22
NIS		 3118 if (PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
3119 GvMULTI_on(PL_argvgv);
3120 (void)gv_AVadd(PL_argvgv);
3121 av_clear(GvAVn(PL_argvgv));
79072805 3122 for (; argc > 0; argc--,argv++) {
3280af22 3123 av_push(GvAVn(PL_argvgv),newSVpv(argv[0],0));
79072805
LW		 3124 }
3125 }
3280af22 3126 if (PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
79072805 3127 HV *hv;
3280af22
NIS		 3128 GvMULTI_on(PL_envgv);
3129 hv = GvHVn(PL_envgv);
3130 hv_magic(hv, PL_envgv, 'E');
4d2c4e07 3131#if !defined( VMS) && !defined(EPOC) /* VMS doesn't have environ array */
4633a7c4
LW		 3132 /* Note that if the supplied env parameter is actually a copy
3133 of the global environ then it may now point to free'd memory
3134 if the environment has been modified since. To avoid this
3135 problem we treat env==NULL as meaning 'use the default'
3136 */
3137 if (!env)
3138 env = environ;
5aabfad6 3139 if (env != environ)
79072805
LW		 3140 environ[0] = Nullch;
3141 for (; *env; env++) {
93a17b20 3142 if (!(s = strchr(*env,'=')))
79072805
LW		 3143 continue;
3144 *s++ = '\0';
60ce6247 3145#if defined(MSDOS)
137443ea 3146 (void)strupr(*env);
3147#endif
79072805
LW		 3148 sv = newSVpv(s--,0);
3149 (void)hv_store(hv, *env, s - *env, sv, 0);
3150 *s = '=';
3e3baf6d
TB		 3151#if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV)
3152 /* Sins of the RTL. See note in my_setenv(). */
76e3520e 3153 (void)PerlEnv_putenv(savepv(*env));
3e3baf6d 3154#endif
fe14fcc3 3155 }
4550b24a 3156#endif
3157#ifdef DYNAMIC_ENV_FETCH
3158 HvNAME(hv) = savepv(ENV_HV_NAME);
3159#endif
79072805 3160 }
bbce6d69 3161 TAINT_NOT;
85e6fe83 3162 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
7766f137 3163 sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
33b78306 3164}
34de22dd 3165
76e3520e 3166STATIC void
cea2e8a9 3167S_init_perllib(pTHX)
34de22dd 3168{
85e6fe83 3169 char *s;
3280af22 3170 if (!PL_tainting) {
552a7a9b 3171#ifndef VMS
76e3520e 3172 s = PerlEnv_getenv("PERL5LIB");
85e6fe83 3173 if (s)
774d564b 3174 incpush(s, TRUE);
85e6fe83 3175 else
76e3520e 3176 incpush(PerlEnv_getenv("PERLLIB"), FALSE);
552a7a9b 3177#else /* VMS */
3178 /* Treat PERL5?LIB as a possible search list logical name -- the
3179 * "natural" VMS idiom for a Unix path string. We allow each
3180 * element to be a set of |-separated directories for compatibility.
3181 */
3182 char buf[256];
3183 int idx = 0;
3184 if (my_trnlnm("PERL5LIB",buf,0))
774d564b 3185 do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
552a7a9b 3186 else
774d564b 3187 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
552a7a9b 3188#endif /* VMS */
85e6fe83 3189 }
34de22dd 3190
c90c0ff4 3191/* Use the ~-expanded versions of APPLLIB (undocumented),
dfe9444c 3192 ARCHLIB PRIVLIB SITEARCH and SITELIB
df5cef82 3193*/
4633a7c4 3194#ifdef APPLLIB_EXP
43051805 3195 incpush(APPLLIB_EXP, TRUE);
16d20bd9 3196#endif
4633a7c4 3197
fed7345c 3198#ifdef ARCHLIB_EXP
774d564b 3199 incpush(ARCHLIB_EXP, FALSE);
a0d0e21e 3200#endif
fed7345c
AD		 3201#ifndef PRIVLIB_EXP
3202#define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
34de22dd 3203#endif
00dc2f4f
GS		 3204#if defined(WIN32)
3205 incpush(PRIVLIB_EXP, TRUE);
3206#else
774d564b 3207 incpush(PRIVLIB_EXP, FALSE);
00dc2f4f 3208#endif
4633a7c4 3209
4b03c463
GS		 3210#if defined(WIN32)
3211 incpush(SITELIB_EXP, TRUE); /* XXX Win32 needs inc_version_list support */
3212#else
4633a7c4 3213#ifdef SITELIB_EXP
29d82f8d 3214 {
189d1e8d
GS		 3215 char *path = SITELIB_EXP;
3216
3217 if (path) {
3218 char buf[1024];
3219 strcpy(buf,path);
3220 if (strrchr(buf,'/')) /* XXX Hack, Configure var needed */
3221 *strrchr(buf,'/') = '\0';
3222 incpush(buf, TRUE);
3223 }
29d82f8d 3224 }
81c6dfba 3225#endif
4b03c463 3226#endif
a3635516
JH		 3227#if defined(PERL_VENDORLIB_EXP)
3228#if defined(WIN32)
265f5c4a 3229 incpush(PERL_VENDORLIB_EXP, TRUE);
a3635516
JH		 3230#else
3231 incpush(PERL_VENDORLIB_EXP, FALSE);
3232#endif
00dc2f4f 3233#endif
3280af22 3234 if (!PL_tainting)
774d564b 3235 incpush(".", FALSE);
3236}
3237
3238#if defined(DOSISH)
3239# define PERLLIB_SEP ';'
3240#else
3241# if defined(VMS)
3242# define PERLLIB_SEP '|'
3243# else
3244# define PERLLIB_SEP ':'
3245# endif
3246#endif
3247#ifndef PERLLIB_MANGLE
3248# define PERLLIB_MANGLE(s,n) (s)
3249#endif
3250
76e3520e 3251STATIC void
cea2e8a9 3252S_incpush(pTHX_ char *p, int addsubdirs)
774d564b 3253{
3254 SV *subdir = Nullsv;
774d564b 3255
3256 if (!p)
3257 return;
3258
3259 if (addsubdirs) {
00db4c45 3260 subdir = sv_newmortal();
774d564b 3261 }
3262
3263 /* Break at all separators */
3264 while (p && *p) {
8c52afec 3265 SV *libdir = NEWSV(55,0);
774d564b 3266 char *s;
3267
3268 /* skip any consecutive separators */
3269 while ( *p == PERLLIB_SEP ) {
3270 /* Uncomment the next line for PATH semantics */
79cb57f6 3271 /* av_push(GvAVn(PL_incgv), newSVpvn(".", 1)); */
774d564b 3272 p++;
3273 }
3274
3275 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
3276 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
3277 (STRLEN)(s - p));
3278 p = s + 1;
3279 }
3280 else {
3281 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
3282 p = Nullch; /* break out */
3283 }
3284
3285 /*
3286 * BEFORE pushing libdir onto @INC we may first push version- and
3287 * archname-specific sub-directories.
3288 */
3289 if (addsubdirs) {
29d82f8d 3290#ifdef PERL_INC_VERSION_LIST
8353b874
GS		 3291 /* Configure terminates PERL_INC_VERSION_LIST with a NULL */
3292 const char *incverlist[] = { PERL_INC_VERSION_LIST };
29d82f8d
GS		 3293 const char **incver;
3294#endif
774d564b 3295 struct stat tmpstatbuf;
aa689395 3296#ifdef VMS
3297 char *unix;
3298 STRLEN len;
774d564b 3299
2d8e6c8d 3300 if ((unix = tounixspec_ts(SvPV(libdir,len),Nullch)) != Nullch) {
aa689395 3301 len = strlen(unix);
3302 while (unix[len-1] == '/') len--; /* Cosmetic */
3303 sv_usepvn(libdir,unix,len);
3304 }
3305 else
bf49b057 3306 PerlIO_printf(Perl_error_log,
aa689395 3307 "Failed to unixify @INC element \"%s\"\n",
2d8e6c8d 3308 SvPV(libdir,len));
aa689395 3309#endif
29d82f8d
GS		 3310 /* .../version/archname if -d .../version/archname */
3311 Perl_sv_setpvf(aTHX_ subdir, "%"SVf"/"PERL_FS_VER_FMT"/%s", libdir,
3312 (int)PERL_REVISION, (int)PERL_VERSION,
3313 (int)PERL_SUBVERSION, ARCHNAME);
76e3520e 3314 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
774d564b 3315 S_ISDIR(tmpstatbuf.st_mode))
29d82f8d 3316 av_push(GvAVn(PL_incgv), newSVsv(subdir));
774d564b 3317
29d82f8d
GS		 3318 /* .../version if -d .../version */
3319 Perl_sv_setpvf(aTHX_ subdir, "%"SVf"/"PERL_FS_VER_FMT, libdir,
3320 (int)PERL_REVISION, (int)PERL_VERSION,
3321 (int)PERL_SUBVERSION);
76e3520e 3322 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
774d564b 3323 S_ISDIR(tmpstatbuf.st_mode))
29d82f8d
GS		 3324 av_push(GvAVn(PL_incgv), newSVsv(subdir));
3325
4b03c463
GS		 3326 /* .../archname if -d .../archname */
3327 Perl_sv_setpvf(aTHX_ subdir, "%"SVf"/%s", libdir, ARCHNAME);
3328 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3329 S_ISDIR(tmpstatbuf.st_mode))
3330 av_push(GvAVn(PL_incgv), newSVsv(subdir));
3331
29d82f8d 3332#ifdef PERL_INC_VERSION_LIST
8353b874 3333 for (incver = incverlist; *incver; incver++) {
29d82f8d
GS		 3334 /* .../xxx if -d .../xxx */
3335 Perl_sv_setpvf(aTHX_ subdir, "%"SVf"/%s", libdir, *incver);
3336 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3337 S_ISDIR(tmpstatbuf.st_mode))
3338 av_push(GvAVn(PL_incgv), newSVsv(subdir));
29d82f8d
GS		 3339 }
3340#endif
774d564b 3341 }
3342
3343 /* finally push this lib directory on the end of @INC */
3280af22 3344 av_push(GvAVn(PL_incgv), libdir);
774d564b 3345 }
34de22dd 3346}
93a17b20 3347
199100c8 3348#ifdef USE_THREADS
76e3520e 3349STATIC struct perl_thread *
cea2e8a9 3350S_init_main_thread(pTHX)
199100c8 3351{
c5be433b 3352#if !defined(PERL_IMPLICIT_CONTEXT)
52e1cb5e 3353 struct perl_thread *thr;
cea2e8a9 3354#endif
199100c8
MB		 3355 XPV *xpv;
3356
52e1cb5e 3357 Newz(53, thr, 1, struct perl_thread);
533c011a 3358 PL_curcop = &PL_compiling;
c5be433b 3359 thr->interp = PERL_GET_INTERP;
199100c8 3360 thr->cvcache = newHV();
54b9620d 3361 thr->threadsv = newAV();
940cb80d 3362 /* thr->threadsvp is set when find_threadsv is called */
199100c8
MB		 3363 thr->specific = newAV();
3364 thr->flags = THRf_R_JOINABLE;
3365 MUTEX_INIT(&thr->mutex);
3366 /* Handcraft thrsv similarly to mess_sv */
533c011a 3367 New(53, PL_thrsv, 1, SV);
199100c8 3368 Newz(53, xpv, 1, XPV);
533c011a
NIS		 3369 SvFLAGS(PL_thrsv) = SVt_PV;
3370 SvANY(PL_thrsv) = (void*)xpv;
3371 SvREFCNT(PL_thrsv) = 1 << 30; /* practically infinite */
3372 SvPVX(PL_thrsv) = (char*)thr;
3373 SvCUR_set(PL_thrsv, sizeof(thr));
3374 SvLEN_set(PL_thrsv, sizeof(thr));
3375 *SvEND(PL_thrsv) = '\0'; /* in the trailing_nul field */
3376 thr->oursv = PL_thrsv;
3377 PL_chopset = " \n-";
3967c732 3378 PL_dumpindent = 4;
533c011a
NIS		 3379
3380 MUTEX_LOCK(&PL_threads_mutex);
3381 PL_nthreads++;
199100c8
MB		 3382 thr->tid = 0;
3383 thr->next = thr;
3384 thr->prev = thr;
533c011a 3385 MUTEX_UNLOCK(&PL_threads_mutex);
199100c8 3386
4b026b9e 3387#ifdef HAVE_THREAD_INTERN
4f63d024 3388 Perl_init_thread_intern(thr);
235db74f
GS		 3389#endif
3390
3391#ifdef SET_THREAD_SELF
3392 SET_THREAD_SELF(thr);
199100c8
MB		 3393#else
3394 thr->self = pthread_self();
235db74f 3395#endif /* SET_THREAD_SELF */
199100c8
MB		 3396 SET_THR(thr);
3397
3398 /*
3399 * These must come after the SET_THR because sv_setpvn does
3400 * SvTAINT and the taint fields require dTHR.
3401 */
533c011a
NIS		 3402 PL_toptarget = NEWSV(0,0);
3403 sv_upgrade(PL_toptarget, SVt_PVFM);
3404 sv_setpvn(PL_toptarget, "", 0);
3405 PL_bodytarget = NEWSV(0,0);
3406 sv_upgrade(PL_bodytarget, SVt_PVFM);
3407 sv_setpvn(PL_bodytarget, "", 0);
3408 PL_formtarget = PL_bodytarget;
79cb57f6 3409 thr->errsv = newSVpvn("", 0);
78857c3c 3410 (void) find_threadsv("@"); /* Ensure $@ is initialised early */
5c0ca799 3411
533c011a 3412 PL_maxscream = -1;
0b94c7bb
GS		 3413 PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp);
3414 PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags);
3415 PL_regint_start = MEMBER_TO_FPTR(Perl_re_intuit_start);
3416 PL_regint_string = MEMBER_TO_FPTR(Perl_re_intuit_string);
3417 PL_regfree = MEMBER_TO_FPTR(Perl_pregfree);
533c011a
NIS		 3418 PL_regindent = 0;
3419 PL_reginterp_cnt = 0;
5c0ca799 3420
199100c8
MB		 3421 return thr;
3422}
3423#endif /* USE_THREADS */
3424
93a17b20 3425void
864dbfa3 3426Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
93a17b20 3427{
11343788 3428 dTHR;
971a9dd3 3429 SV *atsv;
57843af0 3430 line_t oldline = CopLINE(PL_curcop);
312caa8e 3431 CV *cv;
22921e25 3432 STRLEN len;
6224f72b 3433 int ret;
db36c5a1 3434 dJMPENV;
93a17b20 3435
76e3520e 3436 while (AvFILL(paramList) >= 0) {
312caa8e 3437 cv = (CV*)av_shift(paramList);
8990e307 3438 SAVEFREESV(cv);
14dd3ad8
GS		 3439#ifdef PERL_FLEXIBLE_EXCEPTIONS
3440 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_list_body), cv);
3441#else
3442 JMPENV_PUSH(ret);
3443#endif
6224f72b 3444 switch (ret) {
312caa8e 3445 case 0:
14dd3ad8
GS		 3446#ifndef PERL_FLEXIBLE_EXCEPTIONS
3447 call_list_body(cv);
3448#endif
971a9dd3 3449 atsv = ERRSV;
312caa8e
CS		 3450 (void)SvPV(atsv, len);
3451 if (len) {
971a9dd3 3452 STRLEN n_a;
312caa8e 3453 PL_curcop = &PL_compiling;
57843af0 3454 CopLINE_set(PL_curcop, oldline);
312caa8e
CS		 3455 if (paramList == PL_beginav)
3456 sv_catpv(atsv, "BEGIN failed--compilation aborted");
3457 else
4f25aa18
GS		 3458 Perl_sv_catpvf(aTHX_ atsv,
3459 "%s failed--call queue aborted",
7d30b5c4 3460 paramList == PL_checkav ? "CHECK"
4f25aa18
GS		 3461 : paramList == PL_initav ? "INIT"
3462 : "END");
312caa8e
CS		 3463 while (PL_scopestack_ix > oldscope)
3464 LEAVE;
14dd3ad8 3465 JMPENV_POP;
971a9dd3 3466 Perl_croak(aTHX_ "%s", SvPVx(atsv, n_a));
a0d0e21e 3467 }
85e6fe83 3468 break;
6224f72b 3469 case 1:
f86702cc 3470 STATUS_ALL_FAILURE;
85e6fe83 3471 /* FALL THROUGH */
6224f72b 3472 case 2:
85e6fe83 3473 /* my_exit() was called */
3280af22 3474 while (PL_scopestack_ix > oldscope)
2ae324a7 3475 LEAVE;
84902520 3476 FREETMPS;
3280af22 3477 PL_curstash = PL_defstash;
3280af22 3478 PL_curcop = &PL_compiling;
57843af0 3479 CopLINE_set(PL_curcop, oldline);
14dd3ad8 3480 JMPENV_POP;
cc3604b1 3481 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED)) {
3280af22 3482 if (paramList == PL_beginav)
cea2e8a9 3483 Perl_croak(aTHX_ "BEGIN failed--compilation aborted");
85e6fe83 3484 else
4f25aa18 3485 Perl_croak(aTHX_ "%s failed--call queue aborted",
7d30b5c4 3486 paramList == PL_checkav ? "CHECK"
4f25aa18
GS		 3487 : paramList == PL_initav ? "INIT"
3488 : "END");
85e6fe83 3489 }
f86702cc 3490 my_exit_jump();
85e6fe83 3491 /* NOTREACHED */
6224f72b 3492 case 3:
312caa8e
CS		 3493 if (PL_restartop) {
3494 PL_curcop = &PL_compiling;
57843af0 3495 CopLINE_set(PL_curcop, oldline);
312caa8e 3496 JMPENV_JUMP(3);
85e6fe83 3497 }
bf49b057 3498 PerlIO_printf(Perl_error_log, "panic: restartop\n");
312caa8e
CS		 3499 FREETMPS;
3500 break;
8990e307 3501 }
14dd3ad8 3502 JMPENV_POP;
93a17b20 3503 }
93a17b20 3504}
93a17b20 3505
14dd3ad8 3506#ifdef PERL_FLEXIBLE_EXCEPTIONS
312caa8e 3507STATIC void *
14dd3ad8 3508S_vcall_list_body(pTHX_ va_list args)
312caa8e 3509{
312caa8e 3510 CV *cv = va_arg(args, CV*);
14dd3ad8
GS		 3511 return call_list_body(cv);
3512}
3513#endif
312caa8e 3514
14dd3ad8
GS		 3515STATIC void *
3516S_call_list_body(pTHX_ CV *cv)
3517{
312caa8e 3518 PUSHMARK(PL_stack_sp);
864dbfa3 3519 call_sv((SV*)cv, G_EVAL|G_DISCARD);
312caa8e
CS		 3520 return NULL;
3521}
3522
f86702cc 3523void
864dbfa3 3524Perl_my_exit(pTHX_ U32 status)
f86702cc 3525{
5dc0d613
MB		 3526 dTHR;
3527
8b73bbec 3528 DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
a863c7d1 3529 thr, (unsigned long) status));
f86702cc 3530 switch (status) {
3531 case 0:
3532 STATUS_ALL_SUCCESS;
3533 break;
3534 case 1:
3535 STATUS_ALL_FAILURE;
3536 break;
3537 default:
3538 STATUS_NATIVE_SET(status);
3539 break;
3540 }
3541 my_exit_jump();
3542}
3543
3544void
864dbfa3 3545Perl_my_failure_exit(pTHX)
f86702cc 3546{
3547#ifdef VMS
3548 if (vaxc$errno & 1) {
4fdae800 3549 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
3550 STATUS_NATIVE_SET(44);
f86702cc 3551 }
3552 else {
ff0cee69 3553 if (!vaxc$errno && errno) /* unlikely */
4fdae800 3554 STATUS_NATIVE_SET(44);
f86702cc 3555 else
4fdae800 3556 STATUS_NATIVE_SET(vaxc$errno);
f86702cc 3557 }
3558#else
9b599b2a 3559 int exitstatus;
f86702cc 3560 if (errno & 255)
3561 STATUS_POSIX_SET(errno);
9b599b2a
GS		 3562 else {
3563 exitstatus = STATUS_POSIX >> 8;
3564 if (exitstatus & 255)
3565 STATUS_POSIX_SET(exitstatus);
3566 else
3567 STATUS_POSIX_SET(255);
3568 }
f86702cc 3569#endif
3570 my_exit_jump();
93a17b20
LW		 3571}
3572
76e3520e 3573STATIC void
cea2e8a9 3574S_my_exit_jump(pTHX)
f86702cc 3575{
de616352 3576 dTHR;
c09156bb 3577 register PERL_CONTEXT *cx;
f86702cc 3578 I32 gimme;
3579 SV **newsp;
3580
3280af22
NIS		 3581 if (PL_e_script) {
3582 SvREFCNT_dec(PL_e_script);
3583 PL_e_script = Nullsv;
f86702cc 3584 }
3585
3280af22 3586 POPSTACK_TO(PL_mainstack);
f86702cc 3587 if (cxstack_ix >= 0) {
3588 if (cxstack_ix > 0)
3589 dounwind(0);
3280af22 3590 POPBLOCK(cx,PL_curpm);
f86702cc 3591 LEAVE;
3592 }
ff0cee69 3593
6224f72b 3594 JMPENV_JUMP(2);
f86702cc 3595}
873ef191 3596
7a5f8e82 3597#ifdef PERL_OBJECT
873ef191 3598#include "XSUB.h"
51371543 3599#endif
873ef191 3600
0cb96387
GS		 3601static I32
3602read_e_script(pTHXo_ int idx, SV *buf_sv, int maxlen)
873ef191
GS		 3603{
3604 char *p, *nl;
3280af22 3605 p = SvPVX(PL_e_script);
873ef191 3606 nl = strchr(p, '\n');
3280af22 3607 nl = (nl) ? nl+1 : SvEND(PL_e_script);
7dfe3f66 3608 if (nl-p == 0) {
0cb96387 3609 filter_del(read_e_script);
873ef191 3610 return 0;
7dfe3f66 3611 }
873ef191 3612 sv_catpvn(buf_sv, p, nl-p);
3280af22 3613 sv_chop(PL_e_script, nl);
873ef191
GS		 3614 return 1;
3615}
Unnamed repository; edit this file 'description' to name the repository.