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