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
avoid warnings in legacy code (from David Dyck)
[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)
806e7201 223 SvGROW(PL_patchlevel, UTF8_MAXLEN*3+1);
a7cb1f99
GS		 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
10cc9d2a
JH		 988# ifdef USE_64_BIT_INT
989 sv_catpv(PL_Sv," USE_64_BIT_INT");
990# endif
991# ifdef USE_64_BIT_ALL
992 sv_catpv(PL_Sv," USE_64_BIT_ALL");
ac5e8965
JH		 993# endif
994# ifdef USE_LONG_DOUBLE
995 sv_catpv(PL_Sv," USE_LONG_DOUBLE");
996# endif
53430762
JH		 997# ifdef USE_LARGE_FILES
998 sv_catpv(PL_Sv," USE_LARGE_FILES");
999# endif
ac5e8965
JH		 1000# ifdef USE_SOCKS
1001 sv_catpv(PL_Sv," USE_SOCKS");
1002# endif
b363f7ed
GS		 1003# ifdef PERL_OBJECT
1004 sv_catpv(PL_Sv," PERL_OBJECT");
1005# endif
1006# ifdef PERL_IMPLICIT_CONTEXT
1007 sv_catpv(PL_Sv," PERL_IMPLICIT_CONTEXT");
1008# endif
1009# ifdef PERL_IMPLICIT_SYS
1010 sv_catpv(PL_Sv," PERL_IMPLICIT_SYS");
1011# endif
3280af22 1012 sv_catpv(PL_Sv,"\\n\",");
b363f7ed 1013
6224f72b
GS		 1014#if defined(LOCAL_PATCH_COUNT)
1015 if (LOCAL_PATCH_COUNT > 0) {
1016 int i;
3280af22 1017 sv_catpv(PL_Sv,"\" Locally applied patches:\\n\",");
6224f72b 1018 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
3280af22 1019 if (PL_localpatches[i])
cea2e8a9 1020 Perl_sv_catpvf(aTHX_ PL_Sv,"q\" \t%s\n\",",PL_localpatches[i]);
6224f72b
GS		 1021 }
1022 }
1023#endif
cea2e8a9 1024 Perl_sv_catpvf(aTHX_ PL_Sv,"\" Built under %s\\n\"",OSNAME);
6224f72b
GS		 1025#ifdef __DATE__
1026# ifdef __TIME__
cea2e8a9 1027 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
6224f72b 1028# else
cea2e8a9 1029 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled on %s\\n\"",__DATE__);
6224f72b
GS		 1030# endif
1031#endif
3280af22 1032 sv_catpv(PL_Sv, "; \
6224f72b
GS		 1033$\"=\"\\n \"; \
1034@env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; \
1035print \" \\%ENV:\\n @env\\n\" if @env; \
1036print \" \\@INC:\\n @INC\\n\";");
1037 }
1038 else {
3280af22
NIS		 1039 PL_Sv = newSVpv("config_vars(qw(",0);
1040 sv_catpv(PL_Sv, ++s);
1041 sv_catpv(PL_Sv, "))");
6224f72b
GS		 1042 s += strlen(s);
1043 }
3280af22 1044 av_push(PL_preambleav, PL_Sv);
6224f72b
GS		 1045 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
1046 goto reswitch;
1047 case 'x':
3280af22 1048 PL_doextract = TRUE;
6224f72b
GS		 1049 s++;
1050 if (*s)
f4c556ac 1051 cddir = s;
6224f72b
GS		 1052 break;
1053 case 0:
1054 break;
1055 case '-':
1056 if (!*++s || isSPACE(*s)) {
1057 argc--,argv++;
1058 goto switch_end;
1059 }
1060 /* catch use of gnu style long options */
1061 if (strEQ(s, "version")) {
1062 s = "v";
1063 goto reswitch;
1064 }
1065 if (strEQ(s, "help")) {
1066 s = "h";
1067 goto reswitch;
1068 }
1069 s--;
1070 /* FALL THROUGH */
1071 default:
cea2e8a9 1072 Perl_croak(aTHX_ "Unrecognized switch: -%s (-h will show valid options)",s);
8d063cd8
LW		 1073 }
1074 }
6224f72b 1075 switch_end:
54310121 1076
f675dbe5
CB		 1077 if (
1078#ifndef SECURE_INTERNAL_GETENV
1079 !PL_tainting &&
1080#endif
0df16ed7
GS		 1081 (s = PerlEnv_getenv("PERL5OPT")))
1082 {
74288ac8
GS		 1083 while (isSPACE(*s))
1084 s++;
1085 if (*s == '-' && *(s+1) == 'T')
1086 PL_tainting = TRUE;
1087 else {
1088 while (s && *s) {
1089 while (isSPACE(*s))
1090 s++;
1091 if (*s == '-') {
1092 s++;
1093 if (isSPACE(*s))
1094 continue;
1095 }
1096 if (!*s)
1097 break;
1098 if (!strchr("DIMUdmw", *s))
cea2e8a9 1099 Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s);
74288ac8 1100 s = moreswitches(s);
6224f72b 1101 }
6224f72b
GS		 1102 }
1103 }
a0d0e21e 1104
6224f72b
GS		 1105 if (!scriptname)
1106 scriptname = argv[0];
3280af22 1107 if (PL_e_script) {
6224f72b
GS		 1108 argc++,argv--;
1109 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
1110 }
1111 else if (scriptname == Nullch) {
1112#ifdef MSDOS
1113 if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
1114 moreswitches("h");
1115#endif
1116 scriptname = "-";
1117 }
1118
1119 init_perllib();
1120
1121 open_script(scriptname,dosearch,sv,&fdscript);
1122
1123 validate_suid(validarg, scriptname,fdscript);
1124
0b5b802d
GS		 1125#if defined(SIGCHLD) || defined(SIGCLD)
1126 {
1127#ifndef SIGCHLD
1128# define SIGCHLD SIGCLD
1129#endif
1130 Sighandler_t sigstate = rsignal_state(SIGCHLD);
1131 if (sigstate == SIG_IGN) {
1132 if (ckWARN(WARN_SIGNAL))
1133 Perl_warner(aTHX_ WARN_SIGNAL,
1134 "Can't ignore signal CHLD, forcing to default");
1135 (void)rsignal(SIGCHLD, (Sighandler_t)SIG_DFL);
1136 }
1137 }
1138#endif
1139
f4c556ac 1140 if (PL_doextract) {
6224f72b 1141 find_beginning();
f4c556ac
GS		 1142 if (cddir && PerlDir_chdir(cddir) < 0)
1143 Perl_croak(aTHX_ "Can't chdir to %s",cddir);
1144
1145 }
6224f72b 1146
3280af22
NIS		 1147 PL_main_cv = PL_compcv = (CV*)NEWSV(1104,0);
1148 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
1149 CvUNIQUE_on(PL_compcv);
1150
1151 PL_comppad = newAV();
1152 av_push(PL_comppad, Nullsv);
1153 PL_curpad = AvARRAY(PL_comppad);
1154 PL_comppad_name = newAV();
1155 PL_comppad_name_fill = 0;
1156 PL_min_intro_pending = 0;
1157 PL_padix = 0;
6224f72b 1158#ifdef USE_THREADS
79cb57f6 1159 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
533c011a
NIS		 1160 PL_curpad[0] = (SV*)newAV();
1161 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
1162 CvOWNER(PL_compcv) = 0;
1163 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
1164 MUTEX_INIT(CvMUTEXP(PL_compcv));
6224f72b
GS		 1165#endif /* USE_THREADS */
1166
1167 comppadlist = newAV();
1168 AvREAL_off(comppadlist);
3280af22
NIS		 1169 av_store(comppadlist, 0, (SV*)PL_comppad_name);
1170 av_store(comppadlist, 1, (SV*)PL_comppad);
1171 CvPADLIST(PL_compcv) = comppadlist;
6224f72b
GS		 1172
1173 boot_core_UNIVERSAL();
9a34ef1d 1174#ifndef PERL_MICRO
09bef843 1175 boot_core_xsutils();
9a34ef1d 1176#endif
6224f72b
GS		 1177
1178 if (xsinit)
0cb96387 1179 (*xsinit)(aTHXo); /* in case linked C routines want magical variables */
5db16f6a 1180#if defined(VMS) || defined(WIN32) || defined(DJGPP) || defined(__CYGWIN__)
c5be433b 1181 init_os_extras();
6224f72b
GS		 1182#endif
1183
29209bc5
JH		 1184#ifdef USE_SOCKS
1185 SOCKSinit(argv[0]);
1186#endif
1187
6224f72b
GS		 1188 init_predump_symbols();
1189 /* init_postdump_symbols not currently designed to be called */
1190 /* more than once (ENV isn't cleared first, for example) */
1191 /* But running with -u leaves %ENV & @ARGV undefined! XXX */
3280af22 1192 if (!PL_do_undump)
6224f72b
GS		 1193 init_postdump_symbols(argc,argv,env);
1194
1195 init_lexer();
1196
1197 /* now parse the script */
1198
1199 SETERRNO(0,SS$_NORMAL);
3280af22
NIS		 1200 PL_error_count = 0;
1201 if (yyparse() || PL_error_count) {
1202 if (PL_minus_c)
cea2e8a9 1203 Perl_croak(aTHX_ "%s had compilation errors.\n", PL_origfilename);
6224f72b 1204 else {
cea2e8a9 1205 Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
097ee67d 1206 PL_origfilename);
6224f72b
GS		 1207 }
1208 }
57843af0 1209 CopLINE_set(PL_curcop, 0);
3280af22
NIS		 1210 PL_curstash = PL_defstash;
1211 PL_preprocess = FALSE;
1212 if (PL_e_script) {
1213 SvREFCNT_dec(PL_e_script);
1214 PL_e_script = Nullsv;
6224f72b
GS		 1215 }
1216
1217 /* now that script is parsed, we can modify record separator */
3280af22
NIS		 1218 SvREFCNT_dec(PL_rs);
1219 PL_rs = SvREFCNT_inc(PL_nrs);
864dbfa3 1220 sv_setsv(get_sv("/", TRUE), PL_rs);
3280af22 1221 if (PL_do_undump)
6224f72b
GS		 1222 my_unexec();
1223
57843af0
GS		 1224 if (isWARN_ONCE) {
1225 SAVECOPFILE(PL_curcop);
1226 SAVECOPLINE(PL_curcop);
3280af22 1227 gv_check(PL_defstash);
57843af0 1228 }
6224f72b
GS		 1229
1230 LEAVE;
1231 FREETMPS;
1232
1233#ifdef MYMALLOC
1234 if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
1235 dump_mstats("after compilation:");
1236#endif
1237
1238 ENTER;
3280af22 1239 PL_restartop = 0;
312caa8e 1240 return NULL;
6224f72b
GS		 1241}
1242
954c1994
GS		 1243/*
1244=for apidoc perl_run
1245
1246Tells a Perl interpreter to run. See L<perlembed>.
1247
1248=cut
1249*/
1250
6224f72b 1251int
0cb96387 1252perl_run(pTHXx)
6224f72b 1253{
de616352 1254 dTHR;
6224f72b 1255 I32 oldscope;
14dd3ad8 1256 int ret = 0;
db36c5a1 1257 dJMPENV;
cea2e8a9
GS		 1258#ifdef USE_THREADS
1259 dTHX;
1260#endif
6224f72b 1261
3280af22 1262 oldscope = PL_scopestack_ix;
6224f72b 1263
14dd3ad8 1264#ifdef PERL_FLEXIBLE_EXCEPTIONS
312caa8e 1265 redo_body:
14dd3ad8
GS		 1266 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vrun_body), oldscope);
1267#else
1268 JMPENV_PUSH(ret);
1269#endif
6224f72b
GS		 1270 switch (ret) {
1271 case 1:
1272 cxstack_ix = -1; /* start context stack again */
312caa8e 1273 goto redo_body;
14dd3ad8
GS		 1274 case 0: /* normal completion */
1275#ifndef PERL_FLEXIBLE_EXCEPTIONS
1276 redo_body:
1277 run_body(oldscope);
1278#endif
1279 /* FALL THROUGH */
1280 case 2: /* my_exit() */
3280af22 1281 while (PL_scopestack_ix > oldscope)
6224f72b
GS		 1282 LEAVE;
1283 FREETMPS;
3280af22 1284 PL_curstash = PL_defstash;
865be832 1285 if (PL_endav && !PL_minus_c)
3280af22 1286 call_list(oldscope, PL_endav);
6224f72b
GS		 1287#ifdef MYMALLOC
1288 if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
1289 dump_mstats("after execution: ");
1290#endif
14dd3ad8
GS		 1291 ret = STATUS_NATIVE_EXPORT;
1292 break;
6224f72b 1293 case 3:
312caa8e
CS		 1294 if (PL_restartop) {
1295 POPSTACK_TO(PL_mainstack);
1296 goto redo_body;
6224f72b 1297 }
bf49b057 1298 PerlIO_printf(Perl_error_log, "panic: restartop\n");
312caa8e 1299 FREETMPS;
14dd3ad8
GS		 1300 ret = 1;
1301 break;
6224f72b
GS		 1302 }
1303
14dd3ad8
GS		 1304 JMPENV_POP;
1305 return ret;
312caa8e
CS		 1306}
1307
14dd3ad8 1308#ifdef PERL_FLEXIBLE_EXCEPTIONS
312caa8e 1309STATIC void *
14dd3ad8 1310S_vrun_body(pTHX_ va_list args)
312caa8e 1311{
312caa8e
CS		 1312 I32 oldscope = va_arg(args, I32);
1313
14dd3ad8
GS		 1314 return run_body(oldscope);
1315}
1316#endif
1317
1318
1319STATIC void *
1320S_run_body(pTHX_ I32 oldscope)
1321{
1322 dTHR;
1323
6224f72b 1324 DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
3280af22 1325 PL_sawampersand ? "Enabling" : "Omitting"));
6224f72b 1326
3280af22 1327 if (!PL_restartop) {
6224f72b
GS		 1328 DEBUG_x(dump_all());
1329 DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
b900a521
JH		 1330 DEBUG_S(PerlIO_printf(Perl_debug_log, "main thread is 0x%"UVxf"\n",
1331 PTR2UV(thr)));
6224f72b 1332
3280af22 1333 if (PL_minus_c) {
bf49b057 1334 PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename);
6224f72b
GS		 1335 my_exit(0);
1336 }
3280af22 1337 if (PERLDB_SINGLE && PL_DBsingle)
312caa8e 1338 sv_setiv(PL_DBsingle, 1);
3280af22
NIS		 1339 if (PL_initav)
1340 call_list(oldscope, PL_initav);
6224f72b
GS		 1341 }
1342
1343 /* do it */
1344
3280af22 1345 if (PL_restartop) {
533c011a 1346 PL_op = PL_restartop;
3280af22 1347 PL_restartop = 0;
cea2e8a9 1348 CALLRUNOPS(aTHX);
6224f72b 1349 }
3280af22
NIS		 1350 else if (PL_main_start) {
1351 CvDEPTH(PL_main_cv) = 1;
533c011a 1352 PL_op = PL_main_start;
cea2e8a9 1353 CALLRUNOPS(aTHX);
6224f72b
GS		 1354 }
1355
f6b3007c
JH		 1356 my_exit(0);
1357 /* NOTREACHED */
312caa8e 1358 return NULL;
6224f72b
GS		 1359}
1360
954c1994
GS		 1361/*
1362=for apidoc p||get_sv
1363
1364Returns the SV of the specified Perl scalar. If C<create> is set and the
1365Perl variable does not exist then it will be created. If C<create> is not
1366set and the variable does not exist then NULL is returned.
1367
1368=cut
1369*/
1370
6224f72b 1371SV*
864dbfa3 1372Perl_get_sv(pTHX_ const char *name, I32 create)
6224f72b
GS		 1373{
1374 GV *gv;
1375#ifdef USE_THREADS
1376 if (name[1] == '\0' && !isALPHA(name[0])) {
1377 PADOFFSET tmp = find_threadsv(name);
1378 if (tmp != NOT_IN_PAD) {
1379 dTHR;
1380 return THREADSV(tmp);
1381 }
1382 }
1383#endif /* USE_THREADS */
1384 gv = gv_fetchpv(name, create, SVt_PV);
1385 if (gv)
1386 return GvSV(gv);
1387 return Nullsv;
1388}
1389
954c1994
GS		 1390/*
1391=for apidoc p||get_av
1392
1393Returns the AV of the specified Perl array. If C<create> is set and the
1394Perl variable does not exist then it will be created. If C<create> is not
1395set and the variable does not exist then NULL is returned.
1396
1397=cut
1398*/
1399
6224f72b 1400AV*
864dbfa3 1401Perl_get_av(pTHX_ const char *name, I32 create)
6224f72b
GS		 1402{
1403 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
1404 if (create)
1405 return GvAVn(gv);
1406 if (gv)
1407 return GvAV(gv);
1408 return Nullav;
1409}
1410
954c1994
GS		 1411/*
1412=for apidoc p||get_hv
1413
1414Returns the HV of the specified Perl hash. If C<create> is set and the
1415Perl variable does not exist then it will be created. If C<create> is not
1416set and the variable does not exist then NULL is returned.
1417
1418=cut
1419*/
1420
6224f72b 1421HV*
864dbfa3 1422Perl_get_hv(pTHX_ const char *name, I32 create)
6224f72b 1423{
a0d0e21e
LW		 1424 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
1425 if (create)
1426 return GvHVn(gv);
1427 if (gv)
1428 return GvHV(gv);
1429 return Nullhv;
1430}
1431
954c1994
GS		 1432/*
1433=for apidoc p||get_cv
1434
1435Returns the CV of the specified Perl subroutine. If C<create> is set and
1436the Perl subroutine does not exist then it will be declared (which has the
1437same effect as saying C<sub name;>). If C<create> is not set and the
1438subroutine does not exist then NULL is returned.
1439
1440=cut
1441*/
1442
a0d0e21e 1443CV*
864dbfa3 1444Perl_get_cv(pTHX_ const char *name, I32 create)
a0d0e21e
LW		 1445{
1446 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
b099ddc0 1447 /* XXX unsafe for threads if eval_owner isn't held */
f6ec51f7
GS		 1448 /* XXX this is probably not what they think they're getting.
1449 * It has the same effect as "sub name;", i.e. just a forward
1450 * declaration! */
8ebc5c01 1451 if (create && !GvCVu(gv))
774d564b 1452 return newSUB(start_subparse(FALSE, 0),
a0d0e21e 1453 newSVOP(OP_CONST, 0, newSVpv(name,0)),
4633a7c4 1454 Nullop,
a0d0e21e
LW		 1455 Nullop);
1456 if (gv)
8ebc5c01 1457 return GvCVu(gv);
a0d0e21e
LW		 1458 return Nullcv;
1459}
1460
79072805
LW		 1461/* Be sure to refetch the stack pointer after calling these routines. */
1462
954c1994
GS		 1463/*
1464=for apidoc p||call_argv
1465
1466Performs a callback to the specified Perl sub. See L<perlcall>.
1467
1468=cut
1469*/
1470
a0d0e21e 1471I32
864dbfa3 1472Perl_call_argv(pTHX_ const char *sub_name, I32 flags, register char **argv)
8ac85365
NIS		 1473
1474 /* See G_* flags in cop.h */
1475 /* null terminated arg list */
8990e307 1476{
a0d0e21e 1477 dSP;
8990e307 1478
924508f0 1479 PUSHMARK(SP);
a0d0e21e 1480 if (argv) {
8990e307 1481 while (*argv) {
a0d0e21e 1482 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
8990e307
LW		 1483 argv++;
1484 }
a0d0e21e 1485 PUTBACK;
8990e307 1486 }
864dbfa3 1487 return call_pv(sub_name, flags);
8990e307
LW		 1488}
1489
954c1994
GS		 1490/*
1491=for apidoc p||call_pv
1492
1493Performs a callback to the specified Perl sub. See L<perlcall>.
1494
1495=cut
1496*/
1497
a0d0e21e 1498I32
864dbfa3 1499Perl_call_pv(pTHX_ const char *sub_name, I32 flags)
8ac85365
NIS		 1500 /* name of the subroutine */
1501 /* See G_* flags in cop.h */
a0d0e21e 1502{
864dbfa3 1503 return call_sv((SV*)get_cv(sub_name, TRUE), flags);
a0d0e21e
LW		 1504}
1505
954c1994
GS		 1506/*
1507=for apidoc p||call_method
1508
1509Performs a callback to the specified Perl method. The blessed object must
1510be on the stack. See L<perlcall>.
1511
1512=cut
1513*/
1514
a0d0e21e 1515I32
864dbfa3 1516Perl_call_method(pTHX_ const char *methname, I32 flags)
8ac85365
NIS		 1517 /* name of the subroutine */
1518 /* See G_* flags in cop.h */
a0d0e21e
LW		 1519{
1520 dSP;
1521 OP myop;
0f79a09d 1522 if (!PL_op) {
9b94d1dd 1523 Zero(&myop, 1, OP);
533c011a 1524 PL_op = &myop;
0f79a09d 1525 }
a0d0e21e
LW		 1526 XPUSHs(sv_2mortal(newSVpv(methname,0)));
1527 PUTBACK;
cea2e8a9 1528 pp_method();
d33b2eba
GS		 1529 if (PL_op == &myop)
1530 PL_op = Nullop;
864dbfa3 1531 return call_sv(*PL_stack_sp--, flags);
a0d0e21e
LW		 1532}
1533
1534/* May be called with any of a CV, a GV, or an SV containing the name. */
954c1994
GS		 1535/*
1536=for apidoc p||call_sv
1537
1538Performs a callback to the Perl sub whose name is in the SV. See
1539L<perlcall>.
1540
1541=cut
1542*/
1543
a0d0e21e 1544I32
864dbfa3 1545Perl_call_sv(pTHX_ SV *sv, I32 flags)
8ac85365
NIS		 1546
1547 /* See G_* flags in cop.h */
a0d0e21e 1548{
924508f0 1549 dSP;
a0d0e21e 1550 LOGOP myop; /* fake syntax tree node */
aa689395 1551 I32 oldmark;
a0d0e21e 1552 I32 retval;
a0d0e21e 1553 I32 oldscope;
54310121 1554 bool oldcatch = CATCH_GET;
6224f72b 1555 int ret;
533c011a 1556 OP* oldop = PL_op;
db36c5a1 1557 dJMPENV;
1e422769 1558
a0d0e21e
LW		 1559 if (flags & G_DISCARD) {
1560 ENTER;
1561 SAVETMPS;
1562 }
1563
aa689395 1564 Zero(&myop, 1, LOGOP);
54310121 1565 myop.op_next = Nullop;
f51d4af5 1566 if (!(flags & G_NOARGS))
aa689395 1567 myop.op_flags |= OPf_STACKED;
54310121 1568 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1569 (flags & G_ARRAY) ? OPf_WANT_LIST :
1570 OPf_WANT_SCALAR);
462e5cf6 1571 SAVEOP();
533c011a 1572 PL_op = (OP*)&myop;
aa689395 1573
3280af22
NIS		 1574 EXTEND(PL_stack_sp, 1);
1575 *++PL_stack_sp = sv;
aa689395 1576 oldmark = TOPMARK;
3280af22 1577 oldscope = PL_scopestack_ix;
a0d0e21e 1578
3280af22 1579 if (PERLDB_SUB && PL_curstash != PL_debstash
36477c24 1580 /* Handle first BEGIN of -d. */
3280af22 1581 && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub)))
36477c24 1582 /* Try harder, since this may have been a sighandler, thus
1583 * curstash may be meaningless. */
3280af22 1584 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != PL_debstash)
491527d0 1585 && !(flags & G_NODEBUG))
533c011a 1586 PL_op->op_private |= OPpENTERSUB_DB;
a0d0e21e 1587
312caa8e 1588 if (!(flags & G_EVAL)) {
0cdb2077 1589 CATCH_SET(TRUE);
14dd3ad8 1590 call_body((OP*)&myop, FALSE);
312caa8e 1591 retval = PL_stack_sp - (PL_stack_base + oldmark);
0253cb41 1592 CATCH_SET(oldcatch);
312caa8e
CS		 1593 }
1594 else {
533c011a 1595 cLOGOP->op_other = PL_op;
3280af22 1596 PL_markstack_ptr--;
4633a7c4
LW		 1597 /* we're trying to emulate pp_entertry() here */
1598 {
c09156bb 1599 register PERL_CONTEXT *cx;
54310121 1600 I32 gimme = GIMME_V;
4633a7c4
LW		 1601
1602 ENTER;
1603 SAVETMPS;
1604
533c011a 1605 push_return(PL_op->op_next);
3280af22 1606 PUSHBLOCK(cx, CXt_EVAL, PL_stack_sp);
4633a7c4 1607 PUSHEVAL(cx, 0, 0);
533c011a 1608 PL_eval_root = PL_op; /* Only needed so that goto works right. */
4633a7c4 1609
faef0170 1610 PL_in_eval = EVAL_INEVAL;
4633a7c4 1611 if (flags & G_KEEPERR)
faef0170 1612 PL_in_eval |= EVAL_KEEPERR;
4633a7c4 1613 else
38a03e6e 1614 sv_setpv(ERRSV,"");
4633a7c4 1615 }
3280af22 1616 PL_markstack_ptr++;
a0d0e21e 1617
14dd3ad8
GS		 1618#ifdef PERL_FLEXIBLE_EXCEPTIONS
1619 redo_body:
1620 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_body),
db36c5a1 1621 (OP*)&myop, FALSE);
14dd3ad8
GS		 1622#else
1623 JMPENV_PUSH(ret);
1624#endif
6224f72b
GS		 1625 switch (ret) {
1626 case 0:
14dd3ad8
GS		 1627#ifndef PERL_FLEXIBLE_EXCEPTIONS
1628 redo_body:
1629 call_body((OP*)&myop, FALSE);
1630#endif
312caa8e
CS		 1631 retval = PL_stack_sp - (PL_stack_base + oldmark);
1632 if (!(flags & G_KEEPERR))
1633 sv_setpv(ERRSV,"");
a0d0e21e 1634 break;
6224f72b 1635 case 1:
f86702cc 1636 STATUS_ALL_FAILURE;
a0d0e21e 1637 /* FALL THROUGH */
6224f72b 1638 case 2:
a0d0e21e 1639 /* my_exit() was called */
3280af22 1640 PL_curstash = PL_defstash;
a0d0e21e 1641 FREETMPS;
14dd3ad8 1642 JMPENV_POP;
cc3604b1 1643 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
cea2e8a9 1644 Perl_croak(aTHX_ "Callback called exit");
f86702cc 1645 my_exit_jump();
a0d0e21e 1646 /* NOTREACHED */
6224f72b 1647 case 3:
3280af22 1648 if (PL_restartop) {
533c011a 1649 PL_op = PL_restartop;
3280af22 1650 PL_restartop = 0;
312caa8e 1651 goto redo_body;
a0d0e21e 1652 }
3280af22 1653 PL_stack_sp = PL_stack_base + oldmark;
a0d0e21e
LW		 1654 if (flags & G_ARRAY)
1655 retval = 0;
1656 else {
1657 retval = 1;
3280af22 1658 *++PL_stack_sp = &PL_sv_undef;
a0d0e21e 1659 }
312caa8e 1660 break;
a0d0e21e 1661 }
a0d0e21e 1662
3280af22 1663 if (PL_scopestack_ix > oldscope) {
a0a2876f
LW		 1664 SV **newsp;
1665 PMOP *newpm;
1666 I32 gimme;
c09156bb 1667 register PERL_CONTEXT *cx;
a0a2876f
LW		 1668 I32 optype;
1669
1670 POPBLOCK(cx,newpm);
1671 POPEVAL(cx);
1672 pop_return();
3280af22 1673 PL_curpm = newpm;
a0a2876f 1674 LEAVE;
a0d0e21e 1675 }
14dd3ad8 1676 JMPENV_POP;
a0d0e21e 1677 }
1e422769 1678
a0d0e21e 1679 if (flags & G_DISCARD) {
3280af22 1680 PL_stack_sp = PL_stack_base + oldmark;
a0d0e21e
LW		 1681 retval = 0;
1682 FREETMPS;
1683 LEAVE;
1684 }
533c011a 1685 PL_op = oldop;
a0d0e21e
LW		 1686 return retval;
1687}
1688
14dd3ad8 1689#ifdef PERL_FLEXIBLE_EXCEPTIONS
312caa8e 1690STATIC void *
14dd3ad8 1691S_vcall_body(pTHX_ va_list args)
312caa8e
CS		 1692{
1693 OP *myop = va_arg(args, OP*);
1694 int is_eval = va_arg(args, int);
1695
14dd3ad8 1696 call_body(myop, is_eval);
312caa8e
CS		 1697 return NULL;
1698}
14dd3ad8 1699#endif
312caa8e
CS		 1700
1701STATIC void
14dd3ad8 1702S_call_body(pTHX_ OP *myop, int is_eval)
312caa8e
CS		 1703{
1704 dTHR;
1705
1706 if (PL_op == myop) {
1707 if (is_eval)
cea2e8a9 1708 PL_op = Perl_pp_entereval(aTHX);
312caa8e 1709 else
cea2e8a9 1710 PL_op = Perl_pp_entersub(aTHX);
312caa8e
CS		 1711 }
1712 if (PL_op)
cea2e8a9 1713 CALLRUNOPS(aTHX);
312caa8e
CS		 1714}
1715
6e72f9df 1716/* Eval a string. The G_EVAL flag is always assumed. */
8990e307 1717
954c1994
GS		 1718/*
1719=for apidoc p||eval_sv
1720
1721Tells Perl to C<eval> the string in the SV.
1722
1723=cut
1724*/
1725
a0d0e21e 1726I32
864dbfa3 1727Perl_eval_sv(pTHX_ SV *sv, I32 flags)
8ac85365
NIS		 1728
1729 /* See G_* flags in cop.h */
a0d0e21e 1730{
924508f0 1731 dSP;
a0d0e21e 1732 UNOP myop; /* fake syntax tree node */
3280af22 1733 I32 oldmark = SP - PL_stack_base;
4633a7c4 1734 I32 retval;
4633a7c4 1735 I32 oldscope;
6224f72b 1736 int ret;
533c011a 1737 OP* oldop = PL_op;
db36c5a1 1738 dJMPENV;
84902520 1739
4633a7c4
LW		 1740 if (flags & G_DISCARD) {
1741 ENTER;
1742 SAVETMPS;
1743 }
1744
462e5cf6 1745 SAVEOP();
533c011a
NIS		 1746 PL_op = (OP*)&myop;
1747 Zero(PL_op, 1, UNOP);
3280af22
NIS		 1748 EXTEND(PL_stack_sp, 1);
1749 *++PL_stack_sp = sv;
1750 oldscope = PL_scopestack_ix;
79072805 1751
4633a7c4
LW		 1752 if (!(flags & G_NOARGS))
1753 myop.op_flags = OPf_STACKED;
79072805 1754 myop.op_next = Nullop;
6e72f9df 1755 myop.op_type = OP_ENTEREVAL;
54310121 1756 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1757 (flags & G_ARRAY) ? OPf_WANT_LIST :
1758 OPf_WANT_SCALAR);
6e72f9df 1759 if (flags & G_KEEPERR)
1760 myop.op_flags |= OPf_SPECIAL;
4633a7c4 1761
14dd3ad8 1762#ifdef PERL_FLEXIBLE_EXCEPTIONS
312caa8e 1763 redo_body:
14dd3ad8 1764 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_body),
db36c5a1 1765 (OP*)&myop, TRUE);
14dd3ad8
GS		 1766#else
1767 JMPENV_PUSH(ret);
1768#endif
6224f72b
GS		 1769 switch (ret) {
1770 case 0:
14dd3ad8
GS		 1771#ifndef PERL_FLEXIBLE_EXCEPTIONS
1772 redo_body:
1773 call_body((OP*)&myop,TRUE);
1774#endif
312caa8e
CS		 1775 retval = PL_stack_sp - (PL_stack_base + oldmark);
1776 if (!(flags & G_KEEPERR))
1777 sv_setpv(ERRSV,"");
4633a7c4 1778 break;
6224f72b 1779 case 1:
f86702cc 1780 STATUS_ALL_FAILURE;
4633a7c4 1781 /* FALL THROUGH */
6224f72b 1782 case 2:
4633a7c4 1783 /* my_exit() was called */
3280af22 1784 PL_curstash = PL_defstash;
4633a7c4 1785 FREETMPS;
14dd3ad8 1786 JMPENV_POP;
cc3604b1 1787 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
cea2e8a9 1788 Perl_croak(aTHX_ "Callback called exit");
f86702cc 1789 my_exit_jump();
4633a7c4 1790 /* NOTREACHED */
6224f72b 1791 case 3:
3280af22 1792 if (PL_restartop) {
533c011a 1793 PL_op = PL_restartop;
3280af22 1794 PL_restartop = 0;
312caa8e 1795 goto redo_body;
4633a7c4 1796 }
3280af22 1797 PL_stack_sp = PL_stack_base + oldmark;
4633a7c4
LW		 1798 if (flags & G_ARRAY)
1799 retval = 0;
1800 else {
1801 retval = 1;
3280af22 1802 *++PL_stack_sp = &PL_sv_undef;
4633a7c4 1803 }
312caa8e 1804 break;
4633a7c4
LW		 1805 }
1806
14dd3ad8 1807 JMPENV_POP;
4633a7c4 1808 if (flags & G_DISCARD) {
3280af22 1809 PL_stack_sp = PL_stack_base + oldmark;
4633a7c4
LW		 1810 retval = 0;
1811 FREETMPS;
1812 LEAVE;
1813 }
533c011a 1814 PL_op = oldop;
4633a7c4
LW		 1815 return retval;
1816}
1817
954c1994
GS		 1818/*
1819=for apidoc p||eval_pv
1820
1821Tells Perl to C<eval> the given string and return an SV* result.
1822
1823=cut
1824*/
1825
137443ea 1826SV*
864dbfa3 1827Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
137443ea 1828{
1829 dSP;
1830 SV* sv = newSVpv(p, 0);
1831
924508f0 1832 PUSHMARK(SP);
864dbfa3 1833 eval_sv(sv, G_SCALAR);
137443ea 1834 SvREFCNT_dec(sv);
1835
1836 SPAGAIN;
1837 sv = POPs;
1838 PUTBACK;
1839
2d8e6c8d
GS		 1840 if (croak_on_error && SvTRUE(ERRSV)) {
1841 STRLEN n_a;
cea2e8a9 1842 Perl_croak(aTHX_ SvPVx(ERRSV, n_a));
2d8e6c8d 1843 }
137443ea 1844
1845 return sv;
1846}
1847
4633a7c4
LW		 1848/* Require a module. */
1849
954c1994
GS		 1850/*
1851=for apidoc p||require_pv
1852
1853Tells Perl to C<require> a module.
1854
1855=cut
1856*/
1857
4633a7c4 1858void
864dbfa3 1859Perl_require_pv(pTHX_ const char *pv)
4633a7c4 1860{
d3acc0f7
JP		 1861 SV* sv;
1862 dSP;
e788e7d3 1863 PUSHSTACKi(PERLSI_REQUIRE);
d3acc0f7
JP		 1864 PUTBACK;
1865 sv = sv_newmortal();
4633a7c4
LW		 1866 sv_setpv(sv, "require '");
1867 sv_catpv(sv, pv);
1868 sv_catpv(sv, "'");
864dbfa3 1869 eval_sv(sv, G_DISCARD);
d3acc0f7
JP		 1870 SPAGAIN;
1871 POPSTACK;
79072805
LW		 1872}
1873
79072805 1874void
864dbfa3 1875Perl_magicname(pTHX_ char *sym, char *name, I32 namlen)
79072805
LW		 1876{
1877 register GV *gv;
1878
85e6fe83 1879 if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
79072805
LW		 1880 sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
1881}
1882
76e3520e 1883STATIC void
cea2e8a9 1884S_usage(pTHX_ char *name) /* XXX move this out into a module ? */
4633a7c4 1885{
ab821d7f 1886 /* This message really ought to be max 23 lines.
1887 * Removed -h because the user already knows that opton. Others? */
fb73857a 1888
76e3520e 1889 static char *usage_msg[] = {
fb73857a 1890"-0[octal] specify record separator (\\0, if no argument)",
1891"-a autosplit mode with -n or -p (splits $_ into @F)",
46487f74 1892"-C enable native wide character system interfaces",
fb73857a 1893"-c check syntax only (runs BEGIN and END blocks)",
aac3bd0d
GS		 1894"-d[:debugger] run program under debugger",
1895"-D[number/list] set debugging flags (argument is a bit mask or alphabets)",
1896"-e 'command' one line of program (several -e's allowed, omit programfile)",
1897"-F/pattern/ split() pattern for -a switch (//'s are optional)",
1898"-i[extension] edit <> files in place (makes backup if extension supplied)",
1899"-Idirectory specify @INC/#include directory (several -I's allowed)",
fb73857a 1900"-l[octal] enable line ending processing, specifies line terminator",
aac3bd0d
GS		 1901"-[mM][-]module execute `use/no module...' before executing program",
1902"-n assume 'while (<>) { ... }' loop around program",
1903"-p assume loop like -n but print line also, like sed",
1904"-P run program through C preprocessor before compilation",
1905"-s enable rudimentary parsing for switches after programfile",
1906"-S look for programfile using PATH environment variable",
1907"-T enable tainting checks",
1908"-u dump core after parsing program",
fb73857a 1909"-U allow unsafe operations",
aac3bd0d
GS		 1910"-v print version, subversion (includes VERY IMPORTANT perl info)",
1911"-V[:variable] print configuration summary (or a single Config.pm variable)",
1912"-w enable many useful warnings (RECOMMENDED)",
3c0facb2
GS		 1913"-W enable all warnings",
1914"-X disable all warnings",
fb73857a 1915"-x[directory] strip off text before #!perl line and perhaps cd to directory",
1916"\n",
1917NULL
1918};
76e3520e 1919 char **p = usage_msg;
fb73857a 1920
ab821d7f 1921 printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
fb73857a 1922 while (*p)
1923 printf("\n %s", *p++);
4633a7c4
LW		 1924}
1925
79072805
LW		 1926/* This routine handles any switches that can be given during run */
1927
1928char *
864dbfa3 1929Perl_moreswitches(pTHX_ char *s)
79072805
LW		 1930{
1931 I32 numlen;
c07a80fd 1932 U32 rschar;
79072805
LW		 1933
1934 switch (*s) {
1935 case '0':
a863c7d1
MB		 1936 {
1937 dTHR;
dff6d3cd 1938 rschar = (U32)scan_oct(s, 4, &numlen);
3280af22 1939 SvREFCNT_dec(PL_nrs);
c07a80fd 1940 if (rschar & ~((U8)~0))
3280af22 1941 PL_nrs = &PL_sv_undef;
c07a80fd 1942 else if (!rschar && numlen >= 2)
79cb57f6 1943 PL_nrs = newSVpvn("", 0);
c07a80fd 1944 else {
1945 char ch = rschar;
79cb57f6 1946 PL_nrs = newSVpvn(&ch, 1);
79072805
LW		 1947 }
1948 return s + numlen;
a863c7d1 1949 }
46487f74
GS		 1950 case 'C':
1951 PL_widesyscalls = TRUE;
1952 s++;
1953 return s;
2304df62 1954 case 'F':
3280af22
NIS		 1955 PL_minus_F = TRUE;
1956 PL_splitstr = savepv(s + 1);
2304df62
AD		 1957 s += strlen(s);
1958 return s;
79072805 1959 case 'a':
3280af22 1960 PL_minus_a = TRUE;
79072805
LW		 1961 s++;
1962 return s;
1963 case 'c':
3280af22 1964 PL_minus_c = TRUE;
79072805
LW		 1965 s++;
1966 return s;
1967 case 'd':
bbce6d69 1968 forbid_setid("-d");
4633a7c4 1969 s++;
c07a80fd 1970 if (*s == ':' || *s == '=') {
cea2e8a9 1971 my_setenv("PERL5DB", Perl_form(aTHX_ "use Devel::%s;", ++s));
4633a7c4 1972 s += strlen(s);
4633a7c4 1973 }
ed094faf 1974 if (!PL_perldb) {
3280af22 1975 PL_perldb = PERLDB_ALL;
a0d0e21e 1976 init_debugger();
ed094faf 1977 }
79072805
LW		 1978 return s;
1979 case 'D':
0453d815 1980 {
79072805 1981#ifdef DEBUGGING
bbce6d69 1982 forbid_setid("-D");
79072805 1983 if (isALPHA(s[1])) {
8b73bbec 1984 static char debopts[] = "psltocPmfrxuLHXDS";
79072805
LW		 1985 char *d;
1986
93a17b20 1987 for (s++; *s && (d = strchr(debopts,*s)); s++)
3280af22 1988 PL_debug |= 1 << (d - debopts);
79072805
LW		 1989 }
1990 else {
3280af22 1991 PL_debug = atoi(s+1);
79072805
LW		 1992 for (s++; isDIGIT(*s); s++) ;
1993 }
3280af22 1994 PL_debug |= 0x80000000;
79072805 1995#else
0453d815
PM		 1996 dTHR;
1997 if (ckWARN_d(WARN_DEBUGGING))
1998 Perl_warner(aTHX_ WARN_DEBUGGING,
1999 "Recompile perl with -DDEBUGGING to use -D switch\n");
a0d0e21e 2000 for (s++; isALNUM(*s); s++) ;
79072805
LW		 2001#endif
2002 /*SUPPRESS 530*/
2003 return s;
0453d815 2004 }
4633a7c4 2005 case 'h':
3280af22 2006 usage(PL_origargv[0]);
6ad3d225 2007 PerlProc_exit(0);
79072805 2008 case 'i':
3280af22
NIS		 2009 if (PL_inplace)
2010 Safefree(PL_inplace);
2011 PL_inplace = savepv(s+1);
79072805 2012 /*SUPPRESS 530*/
3280af22 2013 for (s = PL_inplace; *s && !isSPACE(*s); s++) ;
7b8d334a 2014 if (*s) {
fb73857a 2015 *s++ = '\0';
7b8d334a
GS		 2016 if (*s == '-') /* Additional switches on #! line. */
2017 s++;
2018 }
fb73857a 2019 return s;
2020 case 'I': /* -I handled both here and in parse_perl() */
bbce6d69 2021 forbid_setid("-I");
fb73857a 2022 ++s;
2023 while (*s && isSPACE(*s))
2024 ++s;
2025 if (*s) {
774d564b 2026 char *e, *p;
0df16ed7
GS		 2027 p = s;
2028 /* ignore trailing spaces (possibly followed by other switches) */
2029 do {
2030 for (e = p; *e && !isSPACE(*e); e++) ;
2031 p = e;
2032 while (isSPACE(*p))
2033 p++;
2034 } while (*p && *p != '-');
2035 e = savepvn(s, e-s);
2036 incpush(e, TRUE);
2037 Safefree(e);
2038 s = p;
2039 if (*s == '-')
2040 s++;
79072805
LW		 2041 }
2042 else
a67e862a 2043 Perl_croak(aTHX_ "No directory specified for -I");
fb73857a 2044 return s;
79072805 2045 case 'l':
3280af22 2046 PL_minus_l = TRUE;
79072805 2047 s++;
3280af22
NIS		 2048 if (PL_ors)
2049 Safefree(PL_ors);
79072805 2050 if (isDIGIT(*s)) {
3280af22
NIS		 2051 PL_ors = savepv("\n");
2052 PL_orslen = 1;
dff6d3cd 2053 *PL_ors = (char)scan_oct(s, 3 + (*s == '0'), &numlen);
79072805
LW		 2054 s += numlen;
2055 }
2056 else {
a863c7d1 2057 dTHR;
3280af22
NIS		 2058 if (RsPARA(PL_nrs)) {
2059 PL_ors = "\n\n";
2060 PL_orslen = 2;
c07a80fd 2061 }
2062 else
3280af22
NIS		 2063 PL_ors = SvPV(PL_nrs, PL_orslen);
2064 PL_ors = savepvn(PL_ors, PL_orslen);
79072805
LW		 2065 }
2066 return s;
1a30305b 2067 case 'M':
bbce6d69 2068 forbid_setid("-M"); /* XXX ? */
1a30305b 2069 /* FALL THROUGH */
2070 case 'm':
bbce6d69 2071 forbid_setid("-m"); /* XXX ? */
1a30305b 2072 if (*++s) {
a5f75d66 2073 char *start;
11343788 2074 SV *sv;
a5f75d66
AD		 2075 char *use = "use ";
2076 /* -M-foo == 'no foo' */
2077 if (*s == '-') { use = "no "; ++s; }
11343788 2078 sv = newSVpv(use,0);
a5f75d66 2079 start = s;
1a30305b 2080 /* We allow -M'Module qw(Foo Bar)' */
c07a80fd 2081 while(isALNUM(*s) || *s==':') ++s;
2082 if (*s != '=') {
11343788 2083 sv_catpv(sv, start);
c07a80fd 2084 if (*(start-1) == 'm') {
2085 if (*s != '\0')
cea2e8a9 2086 Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
11343788 2087 sv_catpv( sv, " ()");
c07a80fd 2088 }
2089 } else {
11343788
MB		 2090 sv_catpvn(sv, start, s-start);
2091 sv_catpv(sv, " split(/,/,q{");
2092 sv_catpv(sv, ++s);
2093 sv_catpv(sv, "})");
c07a80fd 2094 }
1a30305b 2095 s += strlen(s);
5c831c24 2096 if (!PL_preambleav)
3280af22
NIS		 2097 PL_preambleav = newAV();
2098 av_push(PL_preambleav, sv);
1a30305b 2099 }
2100 else
cea2e8a9 2101 Perl_croak(aTHX_ "No space allowed after -%c", *(s-1));
1a30305b 2102 return s;
79072805 2103 case 'n':
3280af22 2104 PL_minus_n = TRUE;
79072805
LW		 2105 s++;
2106 return s;
2107 case 'p':
3280af22 2108 PL_minus_p = TRUE;
79072805
LW		 2109 s++;
2110 return s;
2111 case 's':
bbce6d69 2112 forbid_setid("-s");
3280af22 2113 PL_doswitches = TRUE;
79072805
LW		 2114 s++;
2115 return s;
463ee0b2 2116 case 'T':
3280af22 2117 if (!PL_tainting)
cea2e8a9 2118 Perl_croak(aTHX_ "Too late for \"-T\" option");
463ee0b2
LW		 2119 s++;
2120 return s;
79072805 2121 case 'u':
3280af22 2122 PL_do_undump = TRUE;
79072805
LW		 2123 s++;
2124 return s;
2125 case 'U':
3280af22 2126 PL_unsafe = TRUE;
79072805
LW		 2127 s++;
2128 return s;
2129 case 'v':
b22c7a20 2130 printf(Perl_form(aTHX_ "\nThis is perl, v%vd built for %s",
3cb0bbe5 2131 PL_patchlevel, ARCHNAME));
fb73857a 2132#if defined(LOCAL_PATCH_COUNT)
2133 if (LOCAL_PATCH_COUNT > 0)
2134 printf("\n(with %d registered patch%s, see perl -V for more detail)",
b900a521 2135 (int)LOCAL_PATCH_COUNT, (LOCAL_PATCH_COUNT!=1) ? "es" : "");
a5f75d66 2136#endif
1a30305b 2137
3818b22b 2138 printf("\n\nCopyright 1987-2000, Larry Wall\n");
79072805 2139#ifdef MSDOS
fb73857a 2140 printf("\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
55497cff 2141#endif
2142#ifdef DJGPP
2143 printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
4eb8286e 2144 printf("djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
4633a7c4 2145#endif
79072805 2146#ifdef OS2
5dd60ef7 2147 printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
4eb8286e 2148 "Version 5 port Copyright (c) 1994-1999, Andreas Kaiser, Ilya Zakharevich\n");
79072805 2149#endif
79072805 2150#ifdef atarist
760ac839 2151 printf("atariST series port, ++jrb bammi@cadence.com\n");
79072805 2152#endif
a3f9223b 2153#ifdef __BEOS__
4eb8286e 2154 printf("BeOS port Copyright Tom Spindler, 1997-1999\n");
a3f9223b 2155#endif
1d84e8df 2156#ifdef MPE
4eb8286e 2157 printf("MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-1999\n");
1d84e8df 2158#endif
9d116dd7 2159#ifdef OEMVS
4eb8286e 2160 printf("MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
9d116dd7 2161#endif
495c5fdc 2162#ifdef __VOS__
4eb8286e 2163 printf("Stratus VOS port by Paul_Green@stratus.com, 1997-1999\n");
495c5fdc 2164#endif
092bebab 2165#ifdef __OPEN_VM
4eb8286e 2166 printf("VM/ESA port by Neale Ferguson, 1998-1999\n");
092bebab 2167#endif
a1a0e61e 2168#ifdef POSIX_BC
4eb8286e 2169 printf("BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
a1a0e61e 2170#endif
61ae2fbf 2171#ifdef __MINT__
4eb8286e 2172 printf("MiNT port by Guido Flohr, 1997-1999\n");
61ae2fbf 2173#endif
f83d2536
GS		 2174#ifdef EPOC
2175 printf("EPOC port by Olaf Flebbe, 1999-2000\n");
2176#endif
baed7233
DL		 2177#ifdef BINARY_BUILD_NOTICE
2178 BINARY_BUILD_NOTICE;
2179#endif
760ac839 2180 printf("\n\
79072805 2181Perl may be copied only under the terms of either the Artistic License or the\n\
95103687
GS		 2182GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n\
2183Complete documentation for Perl, including FAQ lists, should be found on\n\
2184this system using `man perl' or `perldoc perl'. If you have access to the\n\
2185Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n");
6ad3d225 2186 PerlProc_exit(0);
79072805 2187 case 'w':
599cee73
PM		 2188 if (! (PL_dowarn & G_WARN_ALL_MASK))
2189 PL_dowarn |= G_WARN_ON;
2190 s++;
2191 return s;
2192 case 'W':
2193 PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
e24b16f9 2194 PL_compiling.cop_warnings = WARN_ALL ;
599cee73
PM		 2195 s++;
2196 return s;
2197 case 'X':
2198 PL_dowarn = G_WARN_ALL_OFF;
e24b16f9 2199 PL_compiling.cop_warnings = WARN_NONE ;
79072805
LW		 2200 s++;
2201 return s;
a0d0e21e 2202 case '*':
79072805
LW		 2203 case ' ':
2204 if (s[1] == '-') /* Additional switches on #! line. */
2205 return s+2;
2206 break;
a0d0e21e 2207 case '-':
79072805 2208 case 0:
51882d45 2209#if defined(WIN32) || !defined(PERL_STRICT_CR)
a868473f
NIS		 2210 case '\r':
2211#endif
79072805
LW		 2212 case '\n':
2213 case '\t':
2214 break;
aa689395 2215#ifdef ALTERNATE_SHEBANG
2216 case 'S': /* OS/2 needs -S on "extproc" line. */
2217 break;
2218#endif
a0d0e21e 2219 case 'P':
3280af22 2220 if (PL_preprocess)
a0d0e21e
LW		 2221 return s+1;
2222 /* FALL THROUGH */
79072805 2223 default:
cea2e8a9 2224 Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
79072805
LW		 2225 }
2226 return Nullch;
2227}
2228
2229/* compliments of Tom Christiansen */
2230
2231/* unexec() can be found in the Gnu emacs distribution */
ee580363 2232/* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
79072805
LW		 2233
2234void
864dbfa3 2235Perl_my_unexec(pTHX)
79072805
LW		 2236{
2237#ifdef UNEXEC
46fc3d4c 2238 SV* prog;
2239 SV* file;
ee580363 2240 int status = 1;
79072805
LW		 2241 extern int etext;
2242
ee580363 2243 prog = newSVpv(BIN_EXP, 0);
46fc3d4c 2244 sv_catpv(prog, "/perl");
6b88bc9c 2245 file = newSVpv(PL_origfilename, 0);
46fc3d4c 2246 sv_catpv(file, ".perldump");
79072805 2247
ee580363
GS		 2248 unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
2249 /* unexec prints msg to stderr in case of failure */
6ad3d225 2250 PerlProc_exit(status);
79072805 2251#else
a5f75d66
AD		 2252# ifdef VMS
2253# include <lib$routines.h>
2254 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
aa689395 2255# else
79072805 2256 ABORT(); /* for use with undump */
aa689395 2257# endif
a5f75d66 2258#endif
79072805
LW		 2259}
2260
cb68f92d
GS		 2261/* initialize curinterp */
2262STATIC void
cea2e8a9 2263S_init_interp(pTHX)
cb68f92d
GS		 2264{
2265
066ef5b5 2266#ifdef PERL_OBJECT /* XXX kludge */
cb68f92d 2267#define I_REINIT \
6b88bc9c
GS		 2268 STMT_START { \
2269 PL_chopset = " \n-"; \
2270 PL_copline = NOLINE; \
2271 PL_curcop = &PL_compiling;\
2272 PL_curcopdb = NULL; \
2273 PL_dbargs = 0; \
3967c732 2274 PL_dumpindent = 4; \
6b88bc9c
GS		 2275 PL_laststatval = -1; \
2276 PL_laststype = OP_STAT; \
2277 PL_maxscream = -1; \
2278 PL_maxsysfd = MAXSYSFD; \
2279 PL_statname = Nullsv; \
2280 PL_tmps_floor = -1; \
2281 PL_tmps_ix = -1; \
2282 PL_op_mask = NULL; \
6b88bc9c
GS		 2283 PL_laststatval = -1; \
2284 PL_laststype = OP_STAT; \
2285 PL_mess_sv = Nullsv; \
2286 PL_splitstr = " "; \
2287 PL_generation = 100; \
2288 PL_exitlist = NULL; \
2289 PL_exitlistlen = 0; \
2290 PL_regindent = 0; \
2291 PL_in_clean_objs = FALSE; \
2292 PL_in_clean_all = FALSE; \
2293 PL_profiledata = NULL; \
2294 PL_rsfp = Nullfp; \
2295 PL_rsfp_filters = Nullav; \
24d3c518 2296 PL_dirty = FALSE; \
cb68f92d 2297 } STMT_END
9666903d 2298 I_REINIT;
066ef5b5
GS		 2299#else
2300# ifdef MULTIPLICITY
2301# define PERLVAR(var,type)
51371543 2302# define PERLVARA(var,n,type)
cea2e8a9 2303# if defined(PERL_IMPLICIT_CONTEXT)
54aff467
GS		 2304# if defined(USE_THREADS)
2305# define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
2306# define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
2307# else /* !USE_THREADS */
2308# define PERLVARI(var,type,init) aTHX->var = init;
2309# define PERLVARIC(var,type,init) aTHX->var = init;
2310# endif /* USE_THREADS */
cea2e8a9 2311# else
c5be433b
GS		 2312# define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
2313# define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
cea2e8a9 2314# endif
066ef5b5
GS		 2315# include "intrpvar.h"
2316# ifndef USE_THREADS
2317# include "thrdvar.h"
2318# endif
2319# undef PERLVAR
51371543 2320# undef PERLVARA
066ef5b5
GS		 2321# undef PERLVARI
2322# undef PERLVARIC
3967c732 2323# else
066ef5b5 2324# define PERLVAR(var,type)
51371543 2325# define PERLVARA(var,n,type)
533c011a
NIS		 2326# define PERLVARI(var,type,init) PL_##var = init;
2327# define PERLVARIC(var,type,init) PL_##var = init;
066ef5b5
GS		 2328# include "intrpvar.h"
2329# ifndef USE_THREADS
2330# include "thrdvar.h"
2331# endif
2332# undef PERLVAR
51371543 2333# undef PERLVARA
066ef5b5
GS		 2334# undef PERLVARI
2335# undef PERLVARIC
2336# endif
cb68f92d
GS		 2337#endif
2338
cb68f92d
GS		 2339}
2340
76e3520e 2341STATIC void
cea2e8a9 2342S_init_main_stash(pTHX)
79072805 2343{
11343788 2344 dTHR;
463ee0b2 2345 GV *gv;
6e72f9df 2346
2347 /* Note that strtab is a rather special HV. Assumptions are made
2348 about not iterating on it, and not adding tie magic to it.
2349 It is properly deallocated in perl_destruct() */
3280af22 2350 PL_strtab = newHV();
5f08fbcd
GS		 2351#ifdef USE_THREADS
2352 MUTEX_INIT(&PL_strtab_mutex);
2353#endif
3280af22
NIS		 2354 HvSHAREKEYS_off(PL_strtab); /* mandatory */
2355 hv_ksplit(PL_strtab, 512);
6e72f9df 2356
3280af22 2357 PL_curstash = PL_defstash = newHV();
79cb57f6 2358 PL_curstname = newSVpvn("main",4);
adbc6bb1
LW		 2359 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
2360 SvREFCNT_dec(GvHV(gv));
3280af22 2361 GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);
463ee0b2 2362 SvREADONLY_on(gv);
3280af22
NIS		 2363 HvNAME(PL_defstash) = savepv("main");
2364 PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
2365 GvMULTI_on(PL_incgv);
2366 PL_hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */
2367 GvMULTI_on(PL_hintgv);
2368 PL_defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
2369 PL_errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
2370 GvMULTI_on(PL_errgv);
2371 PL_replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */
2372 GvMULTI_on(PL_replgv);
cea2e8a9 2373 (void)Perl_form(aTHX_ "%240s",""); /* Preallocate temp - for immediate signals. */
38a03e6e
MB		 2374 sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
2375 sv_setpvn(ERRSV, "", 0);
3280af22 2376 PL_curstash = PL_defstash;
11faa288 2377 CopSTASH_set(&PL_compiling, PL_defstash);
ed094faf 2378 PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
3280af22 2379 PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
4633a7c4 2380 /* We must init $/ before switches are processed. */
864dbfa3 2381 sv_setpvn(get_sv("/", TRUE), "\n", 1);
79072805
LW		 2382}
2383
76e3520e 2384STATIC void
cea2e8a9 2385S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript)
79072805 2386{
0f15f207 2387 dTHR;
79072805 2388 register char *s;
2a92aaa0 2389
6c4ab083 2390 *fdscript = -1;
79072805 2391
3280af22
NIS		 2392 if (PL_e_script) {
2393 PL_origfilename = savepv("-e");
96436eeb 2394 }
6c4ab083
GS		 2395 else {
2396 /* if find_script() returns, it returns a malloc()-ed value */
3280af22 2397 PL_origfilename = scriptname = find_script(scriptname, dosearch, NULL, 1);
6c4ab083
GS		 2398
2399 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
2400 char *s = scriptname + 8;
2401 *fdscript = atoi(s);
2402 while (isDIGIT(*s))
2403 s++;
2404 if (*s) {
2405 scriptname = savepv(s + 1);
3280af22
NIS		 2406 Safefree(PL_origfilename);
2407 PL_origfilename = scriptname;
6c4ab083
GS		 2408 }
2409 }
2410 }
2411
57843af0 2412 CopFILE_set(PL_curcop, PL_origfilename);
3280af22 2413 if (strEQ(PL_origfilename,"-"))
79072805 2414 scriptname = "";
01f988be 2415 if (*fdscript >= 0) {
3280af22 2416 PL_rsfp = PerlIO_fdopen(*fdscript,PERL_SCRIPT_MODE);
96436eeb 2417#if defined(HAS_FCNTL) && defined(F_SETFD)
3280af22
NIS		 2418 if (PL_rsfp)
2419 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1); /* ensure close-on-exec */
96436eeb 2420#endif
2421 }
3280af22 2422 else if (PL_preprocess) {
46fc3d4c 2423 char *cpp_cfg = CPPSTDIN;
79cb57f6 2424 SV *cpp = newSVpvn("",0);
46fc3d4c 2425 SV *cmd = NEWSV(0,0);
2426
2427 if (strEQ(cpp_cfg, "cppstdin"))
cea2e8a9 2428 Perl_sv_catpvf(aTHX_ cpp, "%s/", BIN_EXP);
46fc3d4c 2429 sv_catpv(cpp, cpp_cfg);
79072805 2430
0df16ed7 2431 sv_catpvn(sv, "-I", 2);
fed7345c 2432 sv_catpv(sv,PRIVLIB_EXP);
46fc3d4c 2433
79072805 2434#ifdef MSDOS
cea2e8a9 2435 Perl_sv_setpvf(aTHX_ cmd, "\
79072805
LW		 2436sed %s -e \"/^[^#]/b\" \
2437 -e \"/^#[ ]*include[ ]/b\" \
2438 -e \"/^#[ ]*define[ ]/b\" \
2439 -e \"/^#[ ]*if[ ]/b\" \
2440 -e \"/^#[ ]*ifdef[ ]/b\" \
2441 -e \"/^#[ ]*ifndef[ ]/b\" \
2442 -e \"/^#[ ]*else/b\" \
2443 -e \"/^#[ ]*elif[ ]/b\" \
2444 -e \"/^#[ ]*undef[ ]/b\" \
2445 -e \"/^#[ ]*endif/b\" \
2446 -e \"s/^#.*//\" \
894356b3 2447 %s | %"SVf" -C %"SVf" %s",
6b88bc9c 2448 (PL_doextract ? "-e \"1,/^#/d\n\"" : ""),
79072805 2449#else
092bebab 2450# ifdef __OPEN_VM
cea2e8a9 2451 Perl_sv_setpvf(aTHX_ cmd, "\
092bebab
JH		 2452%s %s -e '/^[^#]/b' \
2453 -e '/^#[ ]*include[ ]/b' \
2454 -e '/^#[ ]*define[ ]/b' \
2455 -e '/^#[ ]*if[ ]/b' \
2456 -e '/^#[ ]*ifdef[ ]/b' \
2457 -e '/^#[ ]*ifndef[ ]/b' \
2458 -e '/^#[ ]*else/b' \
2459 -e '/^#[ ]*elif[ ]/b' \
2460 -e '/^#[ ]*undef[ ]/b' \
2461 -e '/^#[ ]*endif/b' \
2462 -e 's/^[ ]*#.*//' \
894356b3 2463 %s | %"SVf" %"SVf" %s",
092bebab 2464# else
cea2e8a9 2465 Perl_sv_setpvf(aTHX_ cmd, "\
79072805
LW		 2466%s %s -e '/^[^#]/b' \
2467 -e '/^#[ ]*include[ ]/b' \
2468 -e '/^#[ ]*define[ ]/b' \
2469 -e '/^#[ ]*if[ ]/b' \
2470 -e '/^#[ ]*ifdef[ ]/b' \
2471 -e '/^#[ ]*ifndef[ ]/b' \
2472 -e '/^#[ ]*else/b' \
2473 -e '/^#[ ]*elif[ ]/b' \
2474 -e '/^#[ ]*undef[ ]/b' \
2475 -e '/^#[ ]*endif/b' \
2476 -e 's/^[ ]*#.*//' \
894356b3 2477 %s | %"SVf" -C %"SVf" %s",
092bebab 2478# endif
79072805
LW		 2479#ifdef LOC_SED
2480 LOC_SED,
2481#else
2482 "sed",
2483#endif
3280af22 2484 (PL_doextract ? "-e '1,/^#/d\n'" : ""),
79072805 2485#endif
46fc3d4c 2486 scriptname, cpp, sv, CPPMINUS);
3280af22 2487 PL_doextract = FALSE;
79072805 2488#ifdef IAMSUID /* actually, this is caught earlier */
b28d0864 2489 if (PL_euid != PL_uid && !PL_euid) { /* if running suidperl */
79072805 2490#ifdef HAS_SETEUID
b28d0864 2491 (void)seteuid(PL_uid); /* musn't stay setuid root */
79072805
LW		 2492#else
2493#ifdef HAS_SETREUID
b28d0864 2494 (void)setreuid((Uid_t)-1, PL_uid);
85e6fe83
LW		 2495#else
2496#ifdef HAS_SETRESUID
b28d0864 2497 (void)setresuid((Uid_t)-1, PL_uid, (Uid_t)-1);
79072805 2498#else
b28d0864 2499 PerlProc_setuid(PL_uid);
79072805
LW		 2500#endif
2501#endif
85e6fe83 2502#endif
b28d0864 2503 if (PerlProc_geteuid() != PL_uid)
cea2e8a9 2504 Perl_croak(aTHX_ "Can't do seteuid!\n");
79072805
LW		 2505 }
2506#endif /* IAMSUID */
3280af22 2507 PL_rsfp = PerlProc_popen(SvPVX(cmd), "r");
46fc3d4c 2508 SvREFCNT_dec(cmd);
2509 SvREFCNT_dec(cpp);
79072805
LW		 2510 }
2511 else if (!*scriptname) {
bbce6d69 2512 forbid_setid("program input from stdin");
3280af22 2513 PL_rsfp = PerlIO_stdin();
79072805 2514 }
96436eeb 2515 else {
3280af22 2516 PL_rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
96436eeb 2517#if defined(HAS_FCNTL) && defined(F_SETFD)
3280af22
NIS		 2518 if (PL_rsfp)
2519 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1); /* ensure close-on-exec */
96436eeb 2520#endif
2521 }
3280af22 2522 if (!PL_rsfp) {
13281fa4 2523#ifdef DOSUID
a687059c 2524#ifndef IAMSUID /* in case script is not readable before setuid */
6b88bc9c 2525 if (PL_euid &&
cc49e20b 2526 PerlLIO_stat(CopFILE(PL_curcop),&PL_statbuf) >= 0 &&
6b88bc9c
GS		 2527 PL_statbuf.st_mode & (S_ISUID|S_ISGID))
2528 {
46fc3d4c 2529 /* try again */
a7cb1f99 2530 PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, BIN_EXP,
273cf8d1
GS		 2531 (int)PERL_REVISION, (int)PERL_VERSION,
2532 (int)PERL_SUBVERSION), PL_origargv);
cea2e8a9 2533 Perl_croak(aTHX_ "Can't do setuid\n");
13281fa4
LW		 2534 }
2535#endif
2536#endif
cea2e8a9 2537 Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
cc49e20b 2538 CopFILE(PL_curcop), Strerror(errno));
13281fa4 2539 }
79072805 2540}
8d063cd8 2541
7b89560d
JH		 2542/* Mention
2543 * I_SYSSTATVFS HAS_FSTATVFS
2544 * I_SYSMOUNT
c890dc6c 2545 * I_STATFS HAS_FSTATFS HAS_GETFSSTAT
7b89560d
JH		 2546 * I_MNTENT HAS_GETMNTENT HAS_HASMNTOPT
2547 * here so that metaconfig picks them up. */
2548
104d25b7 2549#ifdef IAMSUID
864dbfa3 2550STATIC int
e688b231 2551S_fd_on_nosuid_fs(pTHX_ int fd)
104d25b7 2552{
0545a864
JH		 2553 int check_okay = 0; /* able to do all the required sys/libcalls */
2554 int on_nosuid = 0; /* the fd is on a nosuid fs */
104d25b7 2555/*
ad27e871 2556 * Preferred order: fstatvfs(), fstatfs(), ustat()+getmnt(), getmntent().
e688b231 2557 * fstatvfs() is UNIX98.
0545a864 2558 * fstatfs() is 4.3 BSD.
ad27e871 2559 * ustat()+getmnt() is pre-4.3 BSD.
0545a864
JH		 2560 * getmntent() is O(number-of-mounted-filesystems) and can hang on
2561 * an irrelevant filesystem while trying to reach the right one.
104d25b7
JH		 2562 */
2563
2564# ifdef HAS_FSTATVFS
2565 struct statvfs stfs;
2566 check_okay = fstatvfs(fd, &stfs) == 0;
2567 on_nosuid = check_okay && (stfs.f_flag & ST_NOSUID);
2568# else
0545a864 2569# ifdef PERL_MOUNT_NOSUID
ad27e871
JH		 2570# if defined(HAS_FSTATFS) && \
2571 defined(HAS_STRUCT_STATFS) && \
2572 defined(HAS_STRUCT_STATFS_F_FLAGS)
e688b231 2573 struct statfs stfs;
104d25b7 2574 check_okay = fstatfs(fd, &stfs) == 0;
104d25b7 2575 on_nosuid = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID);
0545a864
JH		 2576# else
2577# if defined(HAS_FSTAT) && \
2578 defined(HAS_USTAT) && \
ad27e871 2579 defined(HAS_GETMNT) && \
65d1664e 2580 defined(HAS_STRUCT_FS_DATA) && \
ad27e871 2581 defined(NOSTAT_ONE)
0545a864
JH		 2582 struct stat fdst;
2583 if (fstat(fd, &fdst) == 0) {
2584 struct ustat us;
2585 if (ustat(fdst.st_dev, &us) == 0) {
2586 struct fs_data fsd;
ad27e871
JH		 2587 /* NOSTAT_ONE here because we're not examining fields which
2588 * vary between that case and STAT_ONE. */
2589 if (getmnt((int*)0, &fsd, (int)0, NOSTAT_ONE, us.f_fname) == 0) {
0545a864
JH		 2590 size_t cmplen = sizeof(us.f_fname);
2591 if (sizeof(fsd.fd_req.path) < cmplen)
2592 cmplen = sizeof(fsd.fd_req.path);
2593 if (strnEQ(fsd.fd_req.path, us.f_fname, cmplen) &&
2594 fdst.st_dev == fsd.fd_req.dev) {
2595 check_okay = 1;
2596 on_nosuid = fsd.fd_req.flags & PERL_MOUNT_NOSUID;
2597 }
2598 }
2599 }
2600 }
2601 }
ad27e871
JH		 2602# endif /* fstat+ustat+getmnt */
2603# endif /* fstatfs */
104d25b7 2604# else
0545a864
JH		 2605# if defined(HAS_GETMNTENT) && \
2606 defined(HAS_HASMNTOPT) && \
2607 defined(MNTOPT_NOSUID)
104d25b7
JH		 2608 FILE *mtab = fopen("/etc/mtab", "r");
2609 struct mntent *entry;
2610 struct stat stb, fsb;
2611
2612 if (mtab && (fstat(fd, &stb) == 0)) {
e688b231
JH		 2613 while (entry = getmntent(mtab)) {
2614 if (stat(entry->mnt_dir, &fsb) == 0
2615 && fsb.st_dev == stb.st_dev)
104d25b7
JH		 2616 {
2617 /* found the filesystem */
2618 check_okay = 1;
2619 if (hasmntopt(entry, MNTOPT_NOSUID))
2620 on_nosuid = 1;
2621 break;
e688b231 2622 } /* A single fs may well fail its stat(). */
104d25b7
JH		 2623 }
2624 }
2625 if (mtab)
2626 fclose(mtab);
ad27e871 2627# endif /* getmntent+hasmntopt */
0545a864 2628# endif /* PERL_MOUNT_NOSUID: fstatfs or fstat+ustat+statfs */
e688b231 2629# endif /* statvfs */
0545a864 2630
104d25b7 2631 if (!check_okay)
0545a864 2632 Perl_croak(aTHX_ "Can't check filesystem of script \"%s\" for nosuid", PL_origfilename);
104d25b7
JH		 2633 return on_nosuid;
2634}
2635#endif /* IAMSUID */
2636
76e3520e 2637STATIC void
cea2e8a9 2638S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript)
79072805 2639{
96436eeb 2640 int which;
2641
13281fa4
LW		 2642 /* do we need to emulate setuid on scripts? */
2643
2644 /* This code is for those BSD systems that have setuid #! scripts disabled
2645 * in the kernel because of a security problem. Merely defining DOSUID
2646 * in perl will not fix that problem, but if you have disabled setuid
2647 * scripts in the kernel, this will attempt to emulate setuid and setgid
2648 * on scripts that have those now-otherwise-useless bits set. The setuid
27e2fb84
LW		 2649 * root version must be called suidperl or sperlN.NNN. If regular perl
2650 * discovers that it has opened a setuid script, it calls suidperl with
2651 * the same argv that it had. If suidperl finds that the script it has
2652 * just opened is NOT setuid root, it sets the effective uid back to the
2653 * uid. We don't just make perl setuid root because that loses the
2654 * effective uid we had before invoking perl, if it was different from the
2655 * uid.
13281fa4
LW		 2656 *
2657 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
2658 * be defined in suidperl only. suidperl must be setuid root. The
2659 * Configure script will set this up for you if you want it.
2660 */
a687059c 2661
13281fa4 2662#ifdef DOSUID
ea0efc06 2663 dTHR;
6e72f9df 2664 char *s, *s2;
a0d0e21e 2665
b28d0864 2666 if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0) /* normal stat is insecure */
cea2e8a9 2667 Perl_croak(aTHX_ "Can't stat script \"%s\"",PL_origfilename);
b28d0864 2668 if (fdscript < 0 && PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
79072805 2669 I32 len;
2d8e6c8d 2670 STRLEN n_a;
13281fa4 2671
a687059c 2672#ifdef IAMSUID
fe14fcc3 2673#ifndef HAS_SETREUID
a687059c
LW		 2674 /* On this access check to make sure the directories are readable,
2675 * there is actually a small window that the user could use to make
2676 * filename point to an accessible directory. So there is a faint
2677 * chance that someone could execute a setuid script down in a
2678 * non-accessible directory. I don't know what to do about that.
2679 * But I don't think it's too important. The manual lies when
2680 * it says access() is useful in setuid programs.
2681 */
cc49e20b 2682 if (PerlLIO_access(CopFILE(PL_curcop),1)) /*double check*/
cea2e8a9 2683 Perl_croak(aTHX_ "Permission denied");
a687059c
LW		 2684#else
2685 /* If we can swap euid and uid, then we can determine access rights
2686 * with a simple stat of the file, and then compare device and
2687 * inode to make sure we did stat() on the same file we opened.
2688 * Then we just have to make sure he or she can execute it.
2689 */
2690 {
2691 struct stat tmpstatbuf;
2692
85e6fe83
LW		 2693 if (
2694#ifdef HAS_SETREUID
b28d0864 2695 setreuid(PL_euid,PL_uid) < 0
a0d0e21e
LW		 2696#else
2697# if HAS_SETRESUID
b28d0864 2698 setresuid(PL_euid,PL_uid,(Uid_t)-1) < 0
a0d0e21e 2699# endif
85e6fe83 2700#endif
b28d0864 2701 || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
cea2e8a9 2702 Perl_croak(aTHX_ "Can't swap uid and euid"); /* really paranoid */
cc49e20b 2703 if (PerlLIO_stat(CopFILE(PL_curcop),&tmpstatbuf) < 0)
cea2e8a9 2704 Perl_croak(aTHX_ "Permission denied"); /* testing full pathname here */
2bb3463c 2705#if defined(IAMSUID) && !defined(NO_NOSUID_CHECK)
e688b231 2706 if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp)))
cea2e8a9 2707 Perl_croak(aTHX_ "Permission denied");
104d25b7 2708#endif
b28d0864
NIS		 2709 if (tmpstatbuf.st_dev != PL_statbuf.st_dev ||
2710 tmpstatbuf.st_ino != PL_statbuf.st_ino) {
2711 (void)PerlIO_close(PL_rsfp);
2712 if (PL_rsfp = PerlProc_popen("/bin/mail root","w")) { /* heh, heh */
2713 PerlIO_printf(PL_rsfp,
785fb66b
JH		 2714"User %"Uid_t_f" tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
2715(Filename of set-id script was %s, uid %"Uid_t_f" gid %"Gid_t_f".)\n\nSincerely,\nperl\n",
2716 PL_uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
b28d0864 2717 (long)PL_statbuf.st_dev, (long)PL_statbuf.st_ino,
cc49e20b 2718 CopFILE(PL_curcop),
785fb66b 2719 PL_statbuf.st_uid, PL_statbuf.st_gid);
b28d0864 2720 (void)PerlProc_pclose(PL_rsfp);
a687059c 2721 }
cea2e8a9 2722 Perl_croak(aTHX_ "Permission denied\n");
a687059c 2723 }
85e6fe83
LW		 2724 if (
2725#ifdef HAS_SETREUID
b28d0864 2726 setreuid(PL_uid,PL_euid) < 0
a0d0e21e
LW		 2727#else
2728# if defined(HAS_SETRESUID)
b28d0864 2729 setresuid(PL_uid,PL_euid,(Uid_t)-1) < 0
a0d0e21e 2730# endif
85e6fe83 2731#endif
b28d0864 2732 || PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid)
cea2e8a9 2733 Perl_croak(aTHX_ "Can't reswap uid and euid");
b28d0864 2734 if (!cando(S_IXUSR,FALSE,&PL_statbuf)) /* can real uid exec? */
cea2e8a9 2735 Perl_croak(aTHX_ "Permission denied\n");
a687059c 2736 }
fe14fcc3 2737#endif /* HAS_SETREUID */
a687059c
LW		 2738#endif /* IAMSUID */
2739
b28d0864 2740 if (!S_ISREG(PL_statbuf.st_mode))
cea2e8a9 2741 Perl_croak(aTHX_ "Permission denied");
b28d0864 2742 if (PL_statbuf.st_mode & S_IWOTH)
cea2e8a9 2743 Perl_croak(aTHX_ "Setuid/gid script is writable by world");
6b88bc9c 2744 PL_doswitches = FALSE; /* -s is insecure in suid */
57843af0 2745 CopLINE_inc(PL_curcop);
6b88bc9c 2746 if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch ||
2d8e6c8d 2747 strnNE(SvPV(PL_linestr,n_a),"#!",2) ) /* required even on Sys V */
cea2e8a9 2748 Perl_croak(aTHX_ "No #! line");
2d8e6c8d 2749 s = SvPV(PL_linestr,n_a)+2;
663a0e37 2750 if (*s == ' ') s++;
45d8adaa 2751 while (!isSPACE(*s)) s++;
2d8e6c8d 2752 for (s2 = s; (s2 > SvPV(PL_linestr,n_a)+2 &&
6e72f9df 2753 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
2754 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
cea2e8a9 2755 Perl_croak(aTHX_ "Not a perl script");
a687059c 2756 while (*s == ' ' || *s == '\t') s++;
13281fa4
LW		 2757 /*
2758 * #! arg must be what we saw above. They can invoke it by
2759 * mentioning suidperl explicitly, but they may not add any strange
2760 * arguments beyond what #! says if they do invoke suidperl that way.
2761 */
2762 len = strlen(validarg);
2763 if (strEQ(validarg," PHOOEY ") ||
45d8adaa 2764 strnNE(s,validarg,len) || !isSPACE(s[len]))
cea2e8a9 2765 Perl_croak(aTHX_ "Args must match #! line");
a687059c
LW		 2766
2767#ifndef IAMSUID
b28d0864
NIS		 2768 if (PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
2769 PL_euid == PL_statbuf.st_uid)
2770 if (!PL_do_undump)
cea2e8a9 2771 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
a687059c
LW		 2772FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2773#endif /* IAMSUID */
13281fa4 2774
b28d0864
NIS		 2775 if (PL_euid) { /* oops, we're not the setuid root perl */
2776 (void)PerlIO_close(PL_rsfp);
13281fa4 2777#ifndef IAMSUID
46fc3d4c 2778 /* try again */
a7cb1f99 2779 PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, BIN_EXP,
273cf8d1
GS		 2780 (int)PERL_REVISION, (int)PERL_VERSION,
2781 (int)PERL_SUBVERSION), PL_origargv);
13281fa4 2782#endif
cea2e8a9 2783 Perl_croak(aTHX_ "Can't do setuid\n");
13281fa4
LW		 2784 }
2785
b28d0864 2786 if (PL_statbuf.st_mode & S_ISGID && PL_statbuf.st_gid != PL_egid) {
fe14fcc3 2787#ifdef HAS_SETEGID
b28d0864 2788 (void)setegid(PL_statbuf.st_gid);
a687059c 2789#else
fe14fcc3 2790#ifdef HAS_SETREGID
b28d0864 2791 (void)setregid((Gid_t)-1,PL_statbuf.st_gid);
85e6fe83
LW		 2792#else
2793#ifdef HAS_SETRESGID
b28d0864 2794 (void)setresgid((Gid_t)-1,PL_statbuf.st_gid,(Gid_t)-1);
a687059c 2795#else
b28d0864 2796 PerlProc_setgid(PL_statbuf.st_gid);
a687059c
LW		 2797#endif
2798#endif
85e6fe83 2799#endif
b28d0864 2800 if (PerlProc_getegid() != PL_statbuf.st_gid)
cea2e8a9 2801 Perl_croak(aTHX_ "Can't do setegid!\n");
83025b21 2802 }
b28d0864
NIS		 2803 if (PL_statbuf.st_mode & S_ISUID) {
2804 if (PL_statbuf.st_uid != PL_euid)
fe14fcc3 2805#ifdef HAS_SETEUID
b28d0864 2806 (void)seteuid(PL_statbuf.st_uid); /* all that for this */
a687059c 2807#else
fe14fcc3 2808#ifdef HAS_SETREUID
b28d0864 2809 (void)setreuid((Uid_t)-1,PL_statbuf.st_uid);
85e6fe83
LW		 2810#else
2811#ifdef HAS_SETRESUID
b28d0864 2812 (void)setresuid((Uid_t)-1,PL_statbuf.st_uid,(Uid_t)-1);
a687059c 2813#else
b28d0864 2814 PerlProc_setuid(PL_statbuf.st_uid);
a687059c
LW		 2815#endif
2816#endif
85e6fe83 2817#endif
b28d0864 2818 if (PerlProc_geteuid() != PL_statbuf.st_uid)
cea2e8a9 2819 Perl_croak(aTHX_ "Can't do seteuid!\n");
a687059c 2820 }
b28d0864 2821 else if (PL_uid) { /* oops, mustn't run as root */
fe14fcc3 2822#ifdef HAS_SETEUID
b28d0864 2823 (void)seteuid((Uid_t)PL_uid);
a687059c 2824#else
fe14fcc3 2825#ifdef HAS_SETREUID
b28d0864 2826 (void)setreuid((Uid_t)-1,(Uid_t)PL_uid);
a687059c 2827#else
85e6fe83 2828#ifdef HAS_SETRESUID
b28d0864 2829 (void)setresuid((Uid_t)-1,(Uid_t)PL_uid,(Uid_t)-1);
85e6fe83 2830#else
b28d0864 2831 PerlProc_setuid((Uid_t)PL_uid);
85e6fe83 2832#endif
a687059c
LW		 2833#endif
2834#endif
b28d0864 2835 if (PerlProc_geteuid() != PL_uid)
cea2e8a9 2836 Perl_croak(aTHX_ "Can't do seteuid!\n");
83025b21 2837 }
748a9306 2838 init_ids();
b28d0864 2839 if (!cando(S_IXUSR,TRUE,&PL_statbuf))
cea2e8a9 2840 Perl_croak(aTHX_ "Permission denied\n"); /* they can't do this */
13281fa4
LW		 2841 }
2842#ifdef IAMSUID
6b88bc9c 2843 else if (PL_preprocess)
cea2e8a9 2844 Perl_croak(aTHX_ "-P not allowed for setuid/setgid script\n");
96436eeb 2845 else if (fdscript >= 0)
cea2e8a9 2846 Perl_croak(aTHX_ "fd script not allowed in suidperl\n");
13281fa4 2847 else
cea2e8a9 2848 Perl_croak(aTHX_ "Script is not setuid/setgid in suidperl\n");
96436eeb 2849
2850 /* We absolutely must clear out any saved ids here, so we */
2851 /* exec the real perl, substituting fd script for scriptname. */
2852 /* (We pass script name as "subdir" of fd, which perl will grok.) */
b28d0864
NIS		 2853 PerlIO_rewind(PL_rsfp);
2854 PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0); /* just in case rewind didn't */
6b88bc9c
GS		 2855 for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;
2856 if (!PL_origargv[which])
cea2e8a9
GS		 2857 Perl_croak(aTHX_ "Permission denied");
2858 PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s",
6b88bc9c 2859 PerlIO_fileno(PL_rsfp), PL_origargv[which]));
96436eeb 2860#if defined(HAS_FCNTL) && defined(F_SETFD)
b28d0864 2861 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0); /* ensure no close-on-exec */
96436eeb 2862#endif
a7cb1f99 2863 PerlProc_execv(Perl_form(aTHX_ "%s/perl"PERL_FS_VER_FMT, BIN_EXP,
273cf8d1
GS		 2864 (int)PERL_REVISION, (int)PERL_VERSION,
2865 (int)PERL_SUBVERSION), PL_origargv);/* try again */
cea2e8a9 2866 Perl_croak(aTHX_ "Can't do setuid\n");
13281fa4 2867#endif /* IAMSUID */
a687059c 2868#else /* !DOSUID */
3280af22 2869 if (PL_euid != PL_uid || PL_egid != PL_gid) { /* (suidperl doesn't exist, in fact) */
a687059c 2870#ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
96827780 2871 dTHR;
b28d0864
NIS		 2872 PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf); /* may be either wrapped or real suid */
2873 if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
a687059c 2874 ||
b28d0864 2875 (PL_egid != PL_gid && PL_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
a687059c 2876 )
b28d0864 2877 if (!PL_do_undump)
cea2e8a9 2878 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
a687059c
LW		 2879FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
2880#endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
2881 /* not set-id, must be wrapped */
a687059c 2882 }
13281fa4 2883#endif /* DOSUID */
79072805 2884}
13281fa4 2885
76e3520e 2886STATIC void
cea2e8a9 2887S_find_beginning(pTHX)
79072805 2888{
6e72f9df 2889 register char *s, *s2;
33b78306
LW		 2890
2891 /* skip forward in input to the real script? */
2892
bbce6d69 2893 forbid_setid("-x");
3280af22
NIS		 2894 while (PL_doextract) {
2895 if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch)
cea2e8a9 2896 Perl_croak(aTHX_ "No Perl script found in input\n");
6e72f9df 2897 if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
3280af22
NIS		 2898 PerlIO_ungetc(PL_rsfp, '\n'); /* to keep line count right */
2899 PL_doextract = FALSE;
6e72f9df 2900 while (*s && !(isSPACE (*s) || *s == '#')) s++;
2901 s2 = s;
2902 while (*s == ' ' || *s == '\t') s++;
2903 if (*s++ == '-') {
2904 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
2905 if (strnEQ(s2-4,"perl",4))
2906 /*SUPPRESS 530*/
2907 while (s = moreswitches(s)) ;
33b78306 2908 }
83025b21
LW		 2909 }
2910 }
2911}
2912
afe37c7d 2913
76e3520e 2914STATIC void
cea2e8a9 2915S_init_ids(pTHX)
352d5a3a 2916{
d8eceb89
JH		 2917 PL_uid = PerlProc_getuid();
2918 PL_euid = PerlProc_geteuid();
2919 PL_gid = PerlProc_getgid();
2920 PL_egid = PerlProc_getegid();
748a9306 2921#ifdef VMS
b28d0864
NIS		 2922 PL_uid |= PL_gid << 16;
2923 PL_euid |= PL_egid << 16;
748a9306 2924#endif
3280af22 2925 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
748a9306 2926}
79072805 2927
76e3520e 2928STATIC void
cea2e8a9 2929S_forbid_setid(pTHX_ char *s)
bbce6d69 2930{
3280af22 2931 if (PL_euid != PL_uid)
cea2e8a9 2932 Perl_croak(aTHX_ "No %s allowed while running setuid", s);
3280af22 2933 if (PL_egid != PL_gid)
cea2e8a9 2934 Perl_croak(aTHX_ "No %s allowed while running setgid", s);
bbce6d69 2935}
2936
1ee4443e
IZ		 2937void
2938Perl_init_debugger(pTHX)
748a9306 2939{
11343788 2940 dTHR;
1ee4443e
IZ		 2941 HV *ostash = PL_curstash;
2942
3280af22
NIS		 2943 PL_curstash = PL_debstash;
2944 PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
2945 AvREAL_off(PL_dbargs);
2946 PL_DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
2947 PL_DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
2948 PL_DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
1ee4443e 2949 sv_upgrade(GvSV(PL_DBsub), SVt_IV); /* IVX accessed if PERLDB_SUB_NN */
3280af22
NIS		 2950 PL_DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
2951 sv_setiv(PL_DBsingle, 0);
2952 PL_DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
2953 sv_setiv(PL_DBtrace, 0);
2954 PL_DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
2955 sv_setiv(PL_DBsignal, 0);
1ee4443e 2956 PL_curstash = ostash;
352d5a3a
LW		 2957}
2958
2ce36478
SM		 2959#ifndef STRESS_REALLOC
2960#define REASONABLE(size) (size)
2961#else
2962#define REASONABLE(size) (1) /* unreasonable */
2963#endif
2964
11343788 2965void
cea2e8a9 2966Perl_init_stacks(pTHX)
79072805 2967{
e336de0d 2968 /* start with 128-item stack and 8K cxstack */
3280af22 2969 PL_curstackinfo = new_stackinfo(REASONABLE(128),
e336de0d 2970 REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
3280af22
NIS		 2971 PL_curstackinfo->si_type = PERLSI_MAIN;
2972 PL_curstack = PL_curstackinfo->si_stack;
2973 PL_mainstack = PL_curstack; /* remember in case we switch stacks */
79072805 2974
3280af22
NIS		 2975 PL_stack_base = AvARRAY(PL_curstack);
2976 PL_stack_sp = PL_stack_base;
2977 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
8990e307 2978
3280af22
NIS		 2979 New(50,PL_tmps_stack,REASONABLE(128),SV*);
2980 PL_tmps_floor = -1;
2981 PL_tmps_ix = -1;
2982 PL_tmps_max = REASONABLE(128);
8990e307 2983
3280af22
NIS		 2984 New(54,PL_markstack,REASONABLE(32),I32);
2985 PL_markstack_ptr = PL_markstack;
2986 PL_markstack_max = PL_markstack + REASONABLE(32);
79072805 2987
ce2f7c3b 2988 SET_MARK_OFFSET;
e336de0d 2989
3280af22
NIS		 2990 New(54,PL_scopestack,REASONABLE(32),I32);
2991 PL_scopestack_ix = 0;
2992 PL_scopestack_max = REASONABLE(32);
79072805 2993
3280af22
NIS		 2994 New(54,PL_savestack,REASONABLE(128),ANY);
2995 PL_savestack_ix = 0;
2996 PL_savestack_max = REASONABLE(128);
79072805 2997
3280af22
NIS		 2998 New(54,PL_retstack,REASONABLE(16),OP*);
2999 PL_retstack_ix = 0;
3000 PL_retstack_max = REASONABLE(16);
378cc40b 3001}
33b78306 3002
2ce36478
SM		 3003#undef REASONABLE
3004
76e3520e 3005STATIC void
cea2e8a9 3006S_nuke_stacks(pTHX)
6e72f9df 3007{
e858de61 3008 dTHR;
3280af22
NIS		 3009 while (PL_curstackinfo->si_next)
3010 PL_curstackinfo = PL_curstackinfo->si_next;
3011 while (PL_curstackinfo) {
3012 PERL_SI *p = PL_curstackinfo->si_prev;
bac4b2ad 3013 /* curstackinfo->si_stack got nuked by sv_free_arenas() */
3280af22
NIS		 3014 Safefree(PL_curstackinfo->si_cxstack);
3015 Safefree(PL_curstackinfo);
3016 PL_curstackinfo = p;
e336de0d 3017 }
3280af22
NIS		 3018 Safefree(PL_tmps_stack);
3019 Safefree(PL_markstack);
3020 Safefree(PL_scopestack);
3021 Safefree(PL_savestack);
3022 Safefree(PL_retstack);
378cc40b 3023}
33b78306 3024
76e3520e 3025#ifndef PERL_OBJECT
760ac839 3026static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
76e3520e 3027#endif
7aa04957 3028
76e3520e 3029STATIC void
cea2e8a9 3030S_init_lexer(pTHX)
8990e307 3031{
76e3520e
GS		 3032#ifdef PERL_OBJECT
3033 PerlIO *tmpfp;
3034#endif
3280af22
NIS		 3035 tmpfp = PL_rsfp;
3036 PL_rsfp = Nullfp;
3037 lex_start(PL_linestr);
3038 PL_rsfp = tmpfp;
79cb57f6 3039 PL_subname = newSVpvn("main",4);
8990e307
LW		 3040}
3041
76e3520e 3042STATIC void
cea2e8a9 3043S_init_predump_symbols(pTHX)
45d8adaa 3044{
11343788 3045 dTHR;
93a17b20 3046 GV *tmpgv;
a0d0e21e 3047 GV *othergv;
af8c498a 3048 IO *io;
79072805 3049
864dbfa3 3050 sv_setpvn(get_sv("\"", TRUE), " ", 1);
3280af22
NIS		 3051 PL_stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
3052 GvMULTI_on(PL_stdingv);
af8c498a
GS		 3053 io = GvIOp(PL_stdingv);
3054 IoIFP(io) = PerlIO_stdin();
adbc6bb1 3055 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
a5f75d66 3056 GvMULTI_on(tmpgv);
af8c498a 3057 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
79072805 3058
85e6fe83 3059 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
a5f75d66 3060 GvMULTI_on(tmpgv);
af8c498a
GS		 3061 io = GvIOp(tmpgv);
3062 IoOFP(io) = IoIFP(io) = PerlIO_stdout();
4633a7c4 3063 setdefout(tmpgv);
adbc6bb1 3064 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
a5f75d66 3065 GvMULTI_on(tmpgv);
af8c498a 3066 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
79072805 3067
bf49b057
GS		 3068 PL_stderrgv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
3069 GvMULTI_on(PL_stderrgv);
3070 io = GvIOp(PL_stderrgv);
af8c498a 3071 IoOFP(io) = IoIFP(io) = PerlIO_stderr();
adbc6bb1 3072 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
a5f75d66 3073 GvMULTI_on(tmpgv);
af8c498a 3074 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
79072805 3075
3280af22 3076 PL_statname = NEWSV(66,0); /* last filename we did stat on */
ab821d7f 3077
3280af22
NIS		 3078 if (!PL_osname)
3079 PL_osname = savepv(OSNAME);
79072805 3080}
33b78306 3081
76e3520e 3082STATIC void
cea2e8a9 3083S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
33b78306 3084{
a863c7d1 3085 dTHR;
79072805
LW		 3086 char *s;
3087 SV *sv;
3088 GV* tmpgv;
fe14fcc3 3089
79072805 3090 argc--,argv++; /* skip name of script */
3280af22 3091 if (PL_doswitches) {
79072805
LW		 3092 for (; argc > 0 && **argv == '-'; argc--,argv++) {
3093 if (!argv[0][1])
3094 break;
379d538a 3095 if (argv[0][1] == '-' && !argv[0][2]) {
79072805
LW		 3096 argc--,argv++;
3097 break;
3098 }
93a17b20 3099 if (s = strchr(argv[0], '=')) {
79072805 3100 *s++ = '\0';
85e6fe83 3101 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
79072805
LW		 3102 }
3103 else
85e6fe83 3104 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
fe14fcc3 3105 }
79072805 3106 }
3280af22
NIS		 3107 PL_toptarget = NEWSV(0,0);
3108 sv_upgrade(PL_toptarget, SVt_PVFM);
3109 sv_setpvn(PL_toptarget, "", 0);
3110 PL_bodytarget = NEWSV(0,0);
3111 sv_upgrade(PL_bodytarget, SVt_PVFM);
3112 sv_setpvn(PL_bodytarget, "", 0);
3113 PL_formtarget = PL_bodytarget;
79072805 3114
bbce6d69 3115 TAINT;
85e6fe83 3116 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
3280af22 3117 sv_setpv(GvSV(tmpgv),PL_origfilename);
79072805
LW		 3118 magicname("0", "0", 1);
3119 }
85e6fe83 3120 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
ed344e4f
IZ		 3121#ifdef OS2
3122 sv_setpv(GvSV(tmpgv), os2_execname());
3123#else
3280af22 3124 sv_setpv(GvSV(tmpgv),PL_origargv[0]);
ed344e4f 3125#endif
3280af22
NIS		 3126 if (PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
3127 GvMULTI_on(PL_argvgv);
3128 (void)gv_AVadd(PL_argvgv);
3129 av_clear(GvAVn(PL_argvgv));
79072805 3130 for (; argc > 0; argc--,argv++) {
3280af22 3131 av_push(GvAVn(PL_argvgv),newSVpv(argv[0],0));
79072805
LW		 3132 }
3133 }
3280af22 3134 if (PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
79072805 3135 HV *hv;
3280af22
NIS		 3136 GvMULTI_on(PL_envgv);
3137 hv = GvHVn(PL_envgv);
3138 hv_magic(hv, PL_envgv, 'E');
4d2c4e07 3139#if !defined( VMS) && !defined(EPOC) /* VMS doesn't have environ array */
4633a7c4
LW		 3140 /* Note that if the supplied env parameter is actually a copy
3141 of the global environ then it may now point to free'd memory
3142 if the environment has been modified since. To avoid this
3143 problem we treat env==NULL as meaning 'use the default'
3144 */
3145 if (!env)
3146 env = environ;
5aabfad6 3147 if (env != environ)
79072805
LW		 3148 environ[0] = Nullch;
3149 for (; *env; env++) {
93a17b20 3150 if (!(s = strchr(*env,'=')))
79072805
LW		 3151 continue;
3152 *s++ = '\0';
60ce6247 3153#if defined(MSDOS)
137443ea 3154 (void)strupr(*env);
3155#endif
79072805
LW		 3156 sv = newSVpv(s--,0);
3157 (void)hv_store(hv, *env, s - *env, sv, 0);
3158 *s = '=';
3e3baf6d
TB		 3159#if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV)
3160 /* Sins of the RTL. See note in my_setenv(). */
76e3520e 3161 (void)PerlEnv_putenv(savepv(*env));
3e3baf6d 3162#endif
fe14fcc3 3163 }
4550b24a 3164#endif
3165#ifdef DYNAMIC_ENV_FETCH
3166 HvNAME(hv) = savepv(ENV_HV_NAME);
3167#endif
79072805 3168 }
bbce6d69 3169 TAINT_NOT;
85e6fe83 3170 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
7766f137 3171 sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
33b78306 3172}
34de22dd 3173
76e3520e 3174STATIC void
cea2e8a9 3175S_init_perllib(pTHX)
34de22dd 3176{
85e6fe83 3177 char *s;
3280af22 3178 if (!PL_tainting) {
552a7a9b 3179#ifndef VMS
76e3520e 3180 s = PerlEnv_getenv("PERL5LIB");
85e6fe83 3181 if (s)
774d564b 3182 incpush(s, TRUE);
85e6fe83 3183 else
76e3520e 3184 incpush(PerlEnv_getenv("PERLLIB"), FALSE);
552a7a9b 3185#else /* VMS */
3186 /* Treat PERL5?LIB as a possible search list logical name -- the
3187 * "natural" VMS idiom for a Unix path string. We allow each
3188 * element to be a set of |-separated directories for compatibility.
3189 */
3190 char buf[256];
3191 int idx = 0;
3192 if (my_trnlnm("PERL5LIB",buf,0))
774d564b 3193 do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
552a7a9b 3194 else
774d564b 3195 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
552a7a9b 3196#endif /* VMS */
85e6fe83 3197 }
34de22dd 3198
c90c0ff4 3199/* Use the ~-expanded versions of APPLLIB (undocumented),
dfe9444c 3200 ARCHLIB PRIVLIB SITEARCH and SITELIB
df5cef82 3201*/
4633a7c4 3202#ifdef APPLLIB_EXP
43051805 3203 incpush(APPLLIB_EXP, TRUE);
16d20bd9 3204#endif
4633a7c4 3205
fed7345c 3206#ifdef ARCHLIB_EXP
774d564b 3207 incpush(ARCHLIB_EXP, FALSE);
a0d0e21e 3208#endif
fed7345c
AD		 3209#ifndef PRIVLIB_EXP
3210#define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
34de22dd 3211#endif
00dc2f4f
GS		 3212#if defined(WIN32)
3213 incpush(PRIVLIB_EXP, TRUE);
3214#else
774d564b 3215 incpush(PRIVLIB_EXP, FALSE);
00dc2f4f 3216#endif
4633a7c4 3217
4b03c463
GS		 3218#if defined(WIN32)
3219 incpush(SITELIB_EXP, TRUE); /* XXX Win32 needs inc_version_list support */
3220#else
4633a7c4 3221#ifdef SITELIB_EXP
29d82f8d 3222 {
189d1e8d
GS		 3223 char *path = SITELIB_EXP;
3224
3225 if (path) {
3226 char buf[1024];
3227 strcpy(buf,path);
3228 if (strrchr(buf,'/')) /* XXX Hack, Configure var needed */
3229 *strrchr(buf,'/') = '\0';
3230 incpush(buf, TRUE);
3231 }
29d82f8d 3232 }
81c6dfba 3233#endif
4b03c463 3234#endif
a3635516
JH		 3235#if defined(PERL_VENDORLIB_EXP)
3236#if defined(WIN32)
265f5c4a 3237 incpush(PERL_VENDORLIB_EXP, TRUE);
a3635516
JH		 3238#else
3239 incpush(PERL_VENDORLIB_EXP, FALSE);
3240#endif
00dc2f4f 3241#endif
3280af22 3242 if (!PL_tainting)
774d564b 3243 incpush(".", FALSE);
3244}
3245
3246#if defined(DOSISH)
3247# define PERLLIB_SEP ';'
3248#else
3249# if defined(VMS)
3250# define PERLLIB_SEP '|'
3251# else
3252# define PERLLIB_SEP ':'
3253# endif
3254#endif
3255#ifndef PERLLIB_MANGLE
3256# define PERLLIB_MANGLE(s,n) (s)
3257#endif
3258
76e3520e 3259STATIC void
cea2e8a9 3260S_incpush(pTHX_ char *p, int addsubdirs)
774d564b 3261{
3262 SV *subdir = Nullsv;
774d564b 3263
3264 if (!p)
3265 return;
3266
3267 if (addsubdirs) {
00db4c45 3268 subdir = sv_newmortal();
774d564b 3269 }
3270
3271 /* Break at all separators */
3272 while (p && *p) {
8c52afec 3273 SV *libdir = NEWSV(55,0);
774d564b 3274 char *s;
3275
3276 /* skip any consecutive separators */
3277 while ( *p == PERLLIB_SEP ) {
3278 /* Uncomment the next line for PATH semantics */
79cb57f6 3279 /* av_push(GvAVn(PL_incgv), newSVpvn(".", 1)); */
774d564b 3280 p++;
3281 }
3282
3283 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
3284 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
3285 (STRLEN)(s - p));
3286 p = s + 1;
3287 }
3288 else {
3289 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
3290 p = Nullch; /* break out */
3291 }
3292
3293 /*
3294 * BEFORE pushing libdir onto @INC we may first push version- and
3295 * archname-specific sub-directories.
3296 */
3297 if (addsubdirs) {
29d82f8d 3298#ifdef PERL_INC_VERSION_LIST
8353b874
GS		 3299 /* Configure terminates PERL_INC_VERSION_LIST with a NULL */
3300 const char *incverlist[] = { PERL_INC_VERSION_LIST };
29d82f8d
GS		 3301 const char **incver;
3302#endif
774d564b 3303 struct stat tmpstatbuf;
aa689395 3304#ifdef VMS
3305 char *unix;
3306 STRLEN len;
774d564b 3307
2d8e6c8d 3308 if ((unix = tounixspec_ts(SvPV(libdir,len),Nullch)) != Nullch) {
aa689395 3309 len = strlen(unix);
3310 while (unix[len-1] == '/') len--; /* Cosmetic */
3311 sv_usepvn(libdir,unix,len);
3312 }
3313 else
bf49b057 3314 PerlIO_printf(Perl_error_log,
aa689395 3315 "Failed to unixify @INC element \"%s\"\n",
2d8e6c8d 3316 SvPV(libdir,len));
aa689395 3317#endif
29d82f8d
GS		 3318 /* .../version/archname if -d .../version/archname */
3319 Perl_sv_setpvf(aTHX_ subdir, "%"SVf"/"PERL_FS_VER_FMT"/%s", libdir,
3320 (int)PERL_REVISION, (int)PERL_VERSION,
3321 (int)PERL_SUBVERSION, ARCHNAME);
76e3520e 3322 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
774d564b 3323 S_ISDIR(tmpstatbuf.st_mode))
29d82f8d 3324 av_push(GvAVn(PL_incgv), newSVsv(subdir));
774d564b 3325
29d82f8d
GS		 3326 /* .../version if -d .../version */
3327 Perl_sv_setpvf(aTHX_ subdir, "%"SVf"/"PERL_FS_VER_FMT, libdir,
3328 (int)PERL_REVISION, (int)PERL_VERSION,
3329 (int)PERL_SUBVERSION);
76e3520e 3330 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
774d564b 3331 S_ISDIR(tmpstatbuf.st_mode))
29d82f8d
GS		 3332 av_push(GvAVn(PL_incgv), newSVsv(subdir));
3333
4b03c463
GS		 3334 /* .../archname if -d .../archname */
3335 Perl_sv_setpvf(aTHX_ subdir, "%"SVf"/%s", libdir, ARCHNAME);
3336 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3337 S_ISDIR(tmpstatbuf.st_mode))
3338 av_push(GvAVn(PL_incgv), newSVsv(subdir));
3339
29d82f8d 3340#ifdef PERL_INC_VERSION_LIST
8353b874 3341 for (incver = incverlist; *incver; incver++) {
29d82f8d
GS		 3342 /* .../xxx if -d .../xxx */
3343 Perl_sv_setpvf(aTHX_ subdir, "%"SVf"/%s", libdir, *incver);
3344 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3345 S_ISDIR(tmpstatbuf.st_mode))
3346 av_push(GvAVn(PL_incgv), newSVsv(subdir));
29d82f8d
GS		 3347 }
3348#endif
774d564b 3349 }
3350
3351 /* finally push this lib directory on the end of @INC */
3280af22 3352 av_push(GvAVn(PL_incgv), libdir);
774d564b 3353 }
34de22dd 3354}
93a17b20 3355
199100c8 3356#ifdef USE_THREADS
76e3520e 3357STATIC struct perl_thread *
cea2e8a9 3358S_init_main_thread(pTHX)
199100c8 3359{
c5be433b 3360#if !defined(PERL_IMPLICIT_CONTEXT)
52e1cb5e 3361 struct perl_thread *thr;
cea2e8a9 3362#endif
199100c8
MB		 3363 XPV *xpv;
3364
52e1cb5e 3365 Newz(53, thr, 1, struct perl_thread);
533c011a 3366 PL_curcop = &PL_compiling;
c5be433b 3367 thr->interp = PERL_GET_INTERP;
199100c8 3368 thr->cvcache = newHV();
54b9620d 3369 thr->threadsv = newAV();
940cb80d 3370 /* thr->threadsvp is set when find_threadsv is called */
199100c8
MB		 3371 thr->specific = newAV();
3372 thr->flags = THRf_R_JOINABLE;
3373 MUTEX_INIT(&thr->mutex);
3374 /* Handcraft thrsv similarly to mess_sv */
533c011a 3375 New(53, PL_thrsv, 1, SV);
199100c8 3376 Newz(53, xpv, 1, XPV);
533c011a
NIS		 3377 SvFLAGS(PL_thrsv) = SVt_PV;
3378 SvANY(PL_thrsv) = (void*)xpv;
3379 SvREFCNT(PL_thrsv) = 1 << 30; /* practically infinite */
3380 SvPVX(PL_thrsv) = (char*)thr;
3381 SvCUR_set(PL_thrsv, sizeof(thr));
3382 SvLEN_set(PL_thrsv, sizeof(thr));
3383 *SvEND(PL_thrsv) = '\0'; /* in the trailing_nul field */
3384 thr->oursv = PL_thrsv;
3385 PL_chopset = " \n-";
3967c732 3386 PL_dumpindent = 4;
533c011a
NIS		 3387
3388 MUTEX_LOCK(&PL_threads_mutex);
3389 PL_nthreads++;
199100c8
MB		 3390 thr->tid = 0;
3391 thr->next = thr;
3392 thr->prev = thr;
533c011a 3393 MUTEX_UNLOCK(&PL_threads_mutex);
199100c8 3394
4b026b9e 3395#ifdef HAVE_THREAD_INTERN
4f63d024 3396 Perl_init_thread_intern(thr);
235db74f
GS		 3397#endif
3398
3399#ifdef SET_THREAD_SELF
3400 SET_THREAD_SELF(thr);
199100c8
MB		 3401#else
3402 thr->self = pthread_self();
235db74f 3403#endif /* SET_THREAD_SELF */
199100c8
MB		 3404 SET_THR(thr);
3405
3406 /*
3407 * These must come after the SET_THR because sv_setpvn does
3408 * SvTAINT and the taint fields require dTHR.
3409 */
533c011a
NIS		 3410 PL_toptarget = NEWSV(0,0);
3411 sv_upgrade(PL_toptarget, SVt_PVFM);
3412 sv_setpvn(PL_toptarget, "", 0);
3413 PL_bodytarget = NEWSV(0,0);
3414 sv_upgrade(PL_bodytarget, SVt_PVFM);
3415 sv_setpvn(PL_bodytarget, "", 0);
3416 PL_formtarget = PL_bodytarget;
79cb57f6 3417 thr->errsv = newSVpvn("", 0);
78857c3c 3418 (void) find_threadsv("@"); /* Ensure $@ is initialised early */
5c0ca799 3419
533c011a 3420 PL_maxscream = -1;
0b94c7bb
GS		 3421 PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp);
3422 PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags);
3423 PL_regint_start = MEMBER_TO_FPTR(Perl_re_intuit_start);
3424 PL_regint_string = MEMBER_TO_FPTR(Perl_re_intuit_string);
3425 PL_regfree = MEMBER_TO_FPTR(Perl_pregfree);
533c011a
NIS		 3426 PL_regindent = 0;
3427 PL_reginterp_cnt = 0;
5c0ca799 3428
199100c8
MB		 3429 return thr;
3430}
3431#endif /* USE_THREADS */
3432
93a17b20 3433void
864dbfa3 3434Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
93a17b20 3435{
11343788 3436 dTHR;
971a9dd3 3437 SV *atsv;
57843af0 3438 line_t oldline = CopLINE(PL_curcop);
312caa8e 3439 CV *cv;
22921e25 3440 STRLEN len;
6224f72b 3441 int ret;
db36c5a1 3442 dJMPENV;
93a17b20 3443
76e3520e 3444 while (AvFILL(paramList) >= 0) {
312caa8e 3445 cv = (CV*)av_shift(paramList);
8990e307 3446 SAVEFREESV(cv);
14dd3ad8
GS		 3447#ifdef PERL_FLEXIBLE_EXCEPTIONS
3448 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_list_body), cv);
3449#else
3450 JMPENV_PUSH(ret);
3451#endif
6224f72b 3452 switch (ret) {
312caa8e 3453 case 0:
14dd3ad8
GS		 3454#ifndef PERL_FLEXIBLE_EXCEPTIONS
3455 call_list_body(cv);
3456#endif
971a9dd3 3457 atsv = ERRSV;
312caa8e
CS		 3458 (void)SvPV(atsv, len);
3459 if (len) {
971a9dd3 3460 STRLEN n_a;
312caa8e 3461 PL_curcop = &PL_compiling;
57843af0 3462 CopLINE_set(PL_curcop, oldline);
312caa8e
CS		 3463 if (paramList == PL_beginav)
3464 sv_catpv(atsv, "BEGIN failed--compilation aborted");
3465 else
4f25aa18
GS		 3466 Perl_sv_catpvf(aTHX_ atsv,
3467 "%s failed--call queue aborted",
7d30b5c4 3468 paramList == PL_checkav ? "CHECK"
4f25aa18
GS		 3469 : paramList == PL_initav ? "INIT"
3470 : "END");
312caa8e
CS		 3471 while (PL_scopestack_ix > oldscope)
3472 LEAVE;
14dd3ad8 3473 JMPENV_POP;
971a9dd3 3474 Perl_croak(aTHX_ "%s", SvPVx(atsv, n_a));
a0d0e21e 3475 }
85e6fe83 3476 break;
6224f72b 3477 case 1:
f86702cc 3478 STATUS_ALL_FAILURE;
85e6fe83 3479 /* FALL THROUGH */
6224f72b 3480 case 2:
85e6fe83 3481 /* my_exit() was called */
3280af22 3482 while (PL_scopestack_ix > oldscope)
2ae324a7 3483 LEAVE;
84902520 3484 FREETMPS;
3280af22 3485 PL_curstash = PL_defstash;
3280af22 3486 PL_curcop = &PL_compiling;
57843af0 3487 CopLINE_set(PL_curcop, oldline);
14dd3ad8 3488 JMPENV_POP;
cc3604b1 3489 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED)) {
3280af22 3490 if (paramList == PL_beginav)
cea2e8a9 3491 Perl_croak(aTHX_ "BEGIN failed--compilation aborted");
85e6fe83 3492 else
4f25aa18 3493 Perl_croak(aTHX_ "%s failed--call queue aborted",
7d30b5c4 3494 paramList == PL_checkav ? "CHECK"
4f25aa18
GS		 3495 : paramList == PL_initav ? "INIT"
3496 : "END");
85e6fe83 3497 }
f86702cc 3498 my_exit_jump();
85e6fe83 3499 /* NOTREACHED */
6224f72b 3500 case 3:
312caa8e
CS		 3501 if (PL_restartop) {
3502 PL_curcop = &PL_compiling;
57843af0 3503 CopLINE_set(PL_curcop, oldline);
312caa8e 3504 JMPENV_JUMP(3);
85e6fe83 3505 }
bf49b057 3506 PerlIO_printf(Perl_error_log, "panic: restartop\n");
312caa8e
CS		 3507 FREETMPS;
3508 break;
8990e307 3509 }
14dd3ad8 3510 JMPENV_POP;
93a17b20 3511 }
93a17b20 3512}
93a17b20 3513
14dd3ad8 3514#ifdef PERL_FLEXIBLE_EXCEPTIONS
312caa8e 3515STATIC void *
14dd3ad8 3516S_vcall_list_body(pTHX_ va_list args)
312caa8e 3517{
312caa8e 3518 CV *cv = va_arg(args, CV*);
14dd3ad8
GS		 3519 return call_list_body(cv);
3520}
3521#endif
312caa8e 3522
14dd3ad8
GS		 3523STATIC void *
3524S_call_list_body(pTHX_ CV *cv)
3525{
312caa8e 3526 PUSHMARK(PL_stack_sp);
864dbfa3 3527 call_sv((SV*)cv, G_EVAL|G_DISCARD);
312caa8e
CS		 3528 return NULL;
3529}
3530
f86702cc 3531void
864dbfa3 3532Perl_my_exit(pTHX_ U32 status)
f86702cc 3533{
5dc0d613
MB		 3534 dTHR;
3535
8b73bbec 3536 DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
a863c7d1 3537 thr, (unsigned long) status));
f86702cc 3538 switch (status) {
3539 case 0:
3540 STATUS_ALL_SUCCESS;
3541 break;
3542 case 1:
3543 STATUS_ALL_FAILURE;
3544 break;
3545 default:
3546 STATUS_NATIVE_SET(status);
3547 break;
3548 }
3549 my_exit_jump();
3550}
3551
3552void
864dbfa3 3553Perl_my_failure_exit(pTHX)
f86702cc 3554{
3555#ifdef VMS
3556 if (vaxc$errno & 1) {
4fdae800 3557 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
3558 STATUS_NATIVE_SET(44);
f86702cc 3559 }
3560 else {
ff0cee69 3561 if (!vaxc$errno && errno) /* unlikely */
4fdae800 3562 STATUS_NATIVE_SET(44);
f86702cc 3563 else
4fdae800 3564 STATUS_NATIVE_SET(vaxc$errno);
f86702cc 3565 }
3566#else
9b599b2a 3567 int exitstatus;
f86702cc 3568 if (errno & 255)
3569 STATUS_POSIX_SET(errno);
9b599b2a
GS		 3570 else {
3571 exitstatus = STATUS_POSIX >> 8;
3572 if (exitstatus & 255)
3573 STATUS_POSIX_SET(exitstatus);
3574 else
3575 STATUS_POSIX_SET(255);
3576 }
f86702cc 3577#endif
3578 my_exit_jump();
93a17b20
LW		 3579}
3580
76e3520e 3581STATIC void
cea2e8a9 3582S_my_exit_jump(pTHX)
f86702cc 3583{
de616352 3584 dTHR;
c09156bb 3585 register PERL_CONTEXT *cx;
f86702cc 3586 I32 gimme;
3587 SV **newsp;
3588
3280af22
NIS		 3589 if (PL_e_script) {
3590 SvREFCNT_dec(PL_e_script);
3591 PL_e_script = Nullsv;
f86702cc 3592 }
3593
3280af22 3594 POPSTACK_TO(PL_mainstack);
f86702cc 3595 if (cxstack_ix >= 0) {
3596 if (cxstack_ix > 0)
3597 dounwind(0);
3280af22 3598 POPBLOCK(cx,PL_curpm);
f86702cc 3599 LEAVE;
3600 }
ff0cee69 3601
6224f72b 3602 JMPENV_JUMP(2);
f86702cc 3603}
873ef191 3604
7a5f8e82 3605#ifdef PERL_OBJECT
873ef191 3606#include "XSUB.h"
51371543 3607#endif
873ef191 3608
0cb96387
GS		 3609static I32
3610read_e_script(pTHXo_ int idx, SV *buf_sv, int maxlen)
873ef191
GS		 3611{
3612 char *p, *nl;
3280af22 3613 p = SvPVX(PL_e_script);
873ef191 3614 nl = strchr(p, '\n');
3280af22 3615 nl = (nl) ? nl+1 : SvEND(PL_e_script);
7dfe3f66 3616 if (nl-p == 0) {
0cb96387 3617 filter_del(read_e_script);
873ef191 3618 return 0;
7dfe3f66 3619 }
873ef191 3620 sv_catpvn(buf_sv, p, nl-p);
3280af22 3621 sv_chop(PL_e_script, nl);
873ef191
GS		 3622 return 1;
3623}
Unnamed repository; edit this file 'description' to name the repository.