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
Make the byte order modifers < and > and the sign modifier ! (for
[perl5.git] / perl.c
CommitLineData
a0d0e21e
LW		 1/* perl.c
2 *
4bb101f2 3 * Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999,
770526c1 4 * 2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others
a687059c 5 *
352d5a3a
LW		 6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
a687059c 8 *
8d063cd8
LW		 9 */
10
a0d0e21e
LW		 11/*
12 * "A ship then new they built for him/of mithril and of elven glass" --Bilbo
13 */
45d8adaa 14
166f8a29
DM		 15/* This file contains the top-level functions that are used to create, use
16 * and destroy a perl interpreter, plus the functions used by XS code to
17 * call back into perl. Note that it does not contain the actual main()
ddfa107c 18 * function of the interpreter; that can be found in perlmain.c
166f8a29
DM		 19 */
20
ae3f3efd
PS		 21/* PSz 12 Nov 03
22 *
23 * Be proud that perl(1) may proclaim:
24 * Setuid Perl scripts are safer than C programs ...
25 * Do not abandon (deprecate) suidperl. Do not advocate C wrappers.
26 *
27 * The flow was: perl starts, notices script is suid, execs suidperl with same
28 * arguments; suidperl opens script, checks many things, sets itself with
29 * right UID, execs perl with similar arguments but with script pre-opened on
30 * /dev/fd/xxx; perl checks script is as should be and does work. This was
31 * insecure: see perlsec(1) for many problems with this approach.
32 *
33 * The "correct" flow should be: perl starts, opens script and notices it is
34 * suid, checks many things, execs suidperl with similar arguments but with
35 * script on /dev/fd/xxx; suidperl checks script and /dev/fd/xxx object are
36 * same, checks arguments match #! line, sets itself with right UID, execs
37 * perl with same arguments; perl checks many things and does work.
38 *
39 * (Opening the script in perl instead of suidperl, we "lose" scripts that
40 * are readable to the target UID but not to the invoker. Where did
41 * unreadable scripts work anyway?)
42 *
43 * For now, suidperl and perl are pretty much the same large and cumbersome
44 * program, so suidperl can check its argument list (see comments elsewhere).
45 *
46 * References:
47 * Original bug report:
48 * http://bugs.perl.org/index.html?req=bug_id&bug_id=20010322.218
49 * http://rt.perl.org/rt2/Ticket/Display.html?id=6511
50 * Comments and discussion with Debian:
51 * http://bugs.debian.org/203426
52 * http://bugs.debian.org/220486
53 * Debian Security Advisory DSA 431-1 (does not fully fix problem):
54 * http://www.debian.org/security/2004/dsa-431
55 * CVE candidate:
56 * http://cve.mitre.org/cgi-bin/cvename.cgi?name=CAN-2003-0618
57 * Previous versions of this patch sent to perl5-porters:
58 * http://www.mail-archive.com/perl5-porters@perl.org/msg71953.html
59 * http://www.mail-archive.com/perl5-porters@perl.org/msg75245.html
60 * http://www.mail-archive.com/perl5-porters@perl.org/msg75563.html
61 * http://www.mail-archive.com/perl5-porters@perl.org/msg75635.html
62 *
63Paul Szabo - psz@maths.usyd.edu.au http://www.maths.usyd.edu.au:8000/u/psz/
64School of Mathematics and Statistics University of Sydney 2006 Australia
65 *
66 */
67/* PSz 13 Nov 03
68 * Use truthful, neat, specific error messages.
69 * Cannot always hide the truth; security must not depend on doing so.
70 */
71
72/* PSz 18 Feb 04
73 * Use global(?), thread-local fdscript for easier checks.
74 * (I do not understand how we could possibly get a thread race:
75 * do not all threads go through the same initialization? Or in
76 * fact, are not threads started only after we get the script and
77 * so know what to do? Oh well, make things super-safe...)
78 */
79
378cc40b 80#include "EXTERN.h"
864dbfa3 81#define PERL_IN_PERL_C
378cc40b 82#include "perl.h"
e3321bb0 83#include "patchlevel.h" /* for local_patches */
378cc40b 84
011f1a1a
JH		 85#ifdef NETWARE
86#include "nwutil.h"
87char *nw_get_sitelib(const char *pl);
88#endif
89
df5cef82 90/* XXX If this causes problems, set i_unistd=undef in the hint file. */
a0d0e21e
LW		 91#ifdef I_UNISTD
92#include <unistd.h>
93#endif
a0d0e21e 94
5311654c
JH		 95#ifdef __BEOS__
96# define HZ 1000000
97#endif
98
99#ifndef HZ
100# ifdef CLK_TCK
101# define HZ CLK_TCK
102# else
103# define HZ 60
104# endif
105#endif
106
7114a2d2 107#if !defined(STANDARD_C) && !defined(HAS_GETENV_PROTOTYPE) && !defined(PERL_MICRO)
20ce7b12 108char *getenv (char *); /* Usually in <stdlib.h> */
54310121 109#endif
110
acfe0abc 111static I32 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen);
0cb96387 112
a687059c
LW		 113#ifdef IAMSUID
114#ifndef DOSUID
115#define DOSUID
116#endif
ae3f3efd 117#endif /* IAMSUID */
378cc40b 118
a687059c
LW		 119#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
120#ifdef DOSUID
121#undef DOSUID
122#endif
123#endif
8d063cd8 124
e6827a76 125static void
daa7d858 126S_init_tls_and_interp(PerlInterpreter *my_perl)
e6827a76
NC		 127{
128 if (!PL_curinterp) {
129 PERL_SET_INTERP(my_perl);
3db8f154 130#if defined(USE_ITHREADS)
e6827a76
NC		 131 INIT_THREADS;
132 ALLOC_THREAD_KEY;
133 PERL_SET_THX(my_perl);
134 OP_REFCNT_INIT;
135 MUTEX_INIT(&PL_dollarzero_mutex);
06d86050 136# endif
e6827a76
NC		 137 }
138 else {
139 PERL_SET_THX(my_perl);
140 }
141}
06d86050 142
32e30700
GS		 143#ifdef PERL_IMPLICIT_SYS
144PerlInterpreter *
7766f137
GS		 145perl_alloc_using(struct IPerlMem* ipM, struct IPerlMem* ipMS,
146 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
32e30700
GS		 147 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
148 struct IPerlDir* ipD, struct IPerlSock* ipS,
149 struct IPerlProc* ipP)
150{
151 PerlInterpreter *my_perl;
32e30700
GS		 152 /* New() needs interpreter, so call malloc() instead */
153 my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
e6827a76 154 S_init_tls_and_interp(my_perl);
32e30700
GS		 155 Zero(my_perl, 1, PerlInterpreter);
156 PL_Mem = ipM;
7766f137
GS		 157 PL_MemShared = ipMS;
158 PL_MemParse = ipMP;
32e30700
GS		 159 PL_Env = ipE;
160 PL_StdIO = ipStd;
161 PL_LIO = ipLIO;
162 PL_Dir = ipD;
163 PL_Sock = ipS;
164 PL_Proc = ipP;
7766f137 165
32e30700
GS		 166 return my_perl;
167}
168#else
954c1994
GS		 169
170/*
ccfc67b7
JH		 171=head1 Embedding Functions
172
954c1994
GS		 173=for apidoc perl_alloc
174
175Allocates a new Perl interpreter. See L<perlembed>.
176
177=cut
178*/
179
93a17b20 180PerlInterpreter *
cea2e8a9 181perl_alloc(void)
79072805 182{
cea2e8a9 183 PerlInterpreter *my_perl;
79072805 184
54aff467 185 /* New() needs interpreter, so call malloc() instead */
e8ee3774 186 my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
ba869deb 187
e6827a76 188 S_init_tls_and_interp(my_perl);
e90e2364 189 return ZeroD(my_perl, 1, PerlInterpreter);
79072805 190}
32e30700 191#endif /* PERL_IMPLICIT_SYS */
79072805 192
954c1994
GS		 193/*
194=for apidoc perl_construct
195
196Initializes a new Perl interpreter. See L<perlembed>.
197
198=cut
199*/
200
79072805 201void
0cb96387 202perl_construct(pTHXx)
79072805 203{
8990e307 204#ifdef MULTIPLICITY
54aff467 205 init_interp();
ac27b0f5 206 PL_perl_destruct_level = 1;
54aff467
GS		 207#else
208 if (PL_perl_destruct_level > 0)
209 init_interp();
210#endif
33f46ff6 211 /* Init the real globals (and main thread)? */
3280af22 212 if (!PL_linestr) {
2aea9f8a
GS		 213 PL_curcop = &PL_compiling; /* needed by ckWARN, right away */
214
3280af22
NIS		 215 PL_linestr = NEWSV(65,79);
216 sv_upgrade(PL_linestr,SVt_PVIV);
79072805 217
3280af22 218 if (!SvREADONLY(&PL_sv_undef)) {
d689ffdd
JP		 219 /* set read-only and try to insure than we wont see REFCNT==0
220 very often */
221
3280af22
NIS		 222 SvREADONLY_on(&PL_sv_undef);
223 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
79072805 224
3280af22 225 sv_setpv(&PL_sv_no,PL_No);
0309f36e
NC		 226 /* value lookup in void context - happens to have the side effect
227 of caching the numeric forms. */
228 SvIV(&PL_sv_no);
3280af22
NIS		 229 SvNV(&PL_sv_no);
230 SvREADONLY_on(&PL_sv_no);
231 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
79072805 232
3280af22 233 sv_setpv(&PL_sv_yes,PL_Yes);
0309f36e 234 SvIV(&PL_sv_yes);
3280af22
NIS		 235 SvNV(&PL_sv_yes);
236 SvREADONLY_on(&PL_sv_yes);
237 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
7996736c
MHM		 238
239 SvREADONLY_on(&PL_sv_placeholder);
240 SvREFCNT(&PL_sv_placeholder) = (~(U32)0)/2;
6e72f9df 241 }
79072805 242
cea2e8a9 243 PL_sighandlerp = Perl_sighandler;
3280af22 244 PL_pidstatus = newHV();
79072805
LW		 245 }
246
8bfdd7d9 247 PL_rs = newSVpvn("\n", 1);
dc92893f 248
cea2e8a9 249 init_stacks();
79072805 250
748a9306 251 init_ids();
3280af22 252 PL_lex_state = LEX_NOTPARSING;
a5f75d66 253
312caa8e 254 JMPENV_BOOTSTRAP;
f86702cc 255 STATUS_ALL_SUCCESS;
256
0672f40e 257 init_i18nl10n(1);
36477c24 258 SET_NUMERIC_STANDARD();
0b5b802d 259
ab821d7f 260#if defined(LOCAL_PATCH_COUNT)
3280af22 261 PL_localpatches = local_patches; /* For possible -v */
ab821d7f 262#endif
263
52853b95
GS		 264#ifdef HAVE_INTERP_INTERN
265 sys_intern_init();
266#endif
267
3a1ee7e8 268 PerlIO_init(aTHX); /* Hook to IO system */
760ac839 269
3280af22
NIS		 270 PL_fdpid = newAV(); /* for remembering popen pids by fd */
271 PL_modglobal = newHV(); /* pointers to per-interpreter module globals */
24944567 272 PL_errors = newSVpvn("",0);
48c6b404 273 sv_setpvn(PERL_DEBUG_PAD(0), "", 0); /* For regex debugging. */
1f483ca1
JH		 274 sv_setpvn(PERL_DEBUG_PAD(1), "", 0); /* ext/re needs these */
275 sv_setpvn(PERL_DEBUG_PAD(2), "", 0); /* even without DEBUGGING. */
1fcf4c12 276#ifdef USE_ITHREADS
13137afc
AB		 277 PL_regex_padav = newAV();
278 av_push(PL_regex_padav,(SV*)newAV()); /* First entry is an array of empty elements */
279 PL_regex_pad = AvARRAY(PL_regex_padav);
1fcf4c12 280#endif
e5dd39fc 281#ifdef USE_REENTRANT_API
59bd0823 282 Perl_reentrant_init(aTHX);
e5dd39fc 283#endif
3d47000e
AB		 284
285 /* Note that strtab is a rather special HV. Assumptions are made
286 about not iterating on it, and not adding tie magic to it.
287 It is properly deallocated in perl_destruct() */
288 PL_strtab = newHV();
289
3d47000e
AB		 290 HvSHAREKEYS_off(PL_strtab); /* mandatory */
291 hv_ksplit(PL_strtab, 512);
292
0631ea03
AB		 293#if defined(__DYNAMIC__) && (defined(NeXT) || defined(__NeXT__))
294 _dyld_lookup_and_bind
295 ("__environ", (unsigned long *) &environ_pointer, NULL);
296#endif /* environ */
297
2f42fcb0
JH		 298#ifndef PERL_MICRO
299# ifdef USE_ENVIRON_ARRAY
0631ea03 300 PL_origenviron = environ;
2f42fcb0 301# endif
0631ea03
AB		 302#endif
303
5311654c 304 /* Use sysconf(_SC_CLK_TCK) if available, if not
dbc1d986
IW		 305 * available or if the sysconf() fails, use the HZ.
306 * BeOS has those, but returns the wrong value. */
307#if defined(HAS_SYSCONF) && defined(_SC_CLK_TCK) && !defined(__BEOS__)
5311654c
JH		 308 PL_clocktick = sysconf(_SC_CLK_TCK);
309 if (PL_clocktick <= 0)
310#endif
311 PL_clocktick = HZ;
312
081fc587
AB		 313 PL_stashcache = newHV();
314
d7aa5382
JP		 315 PL_patchlevel = newSVpv(
316 Perl_form(aTHX_ "%d.%d.%d",
317 (int)PERL_REVISION,
318 (int)PERL_VERSION,
319 (int)PERL_SUBVERSION ), 0
320 );
321
8990e307 322 ENTER;
79072805
LW		 323}
324
954c1994 325/*
62375a60
NIS		 326=for apidoc nothreadhook
327
328Stub that provides thread hook for perl_destruct when there are
329no threads.
330
331=cut
332*/
333
334int
4e9e3734 335Perl_nothreadhook(pTHX)
62375a60
NIS		 336{
337 return 0;
338}
339
340/*
954c1994
GS		 341=for apidoc perl_destruct
342
343Shuts down a Perl interpreter. See L<perlembed>.
344
345=cut
346*/
347
31d77e54 348int
0cb96387 349perl_destruct(pTHXx)
79072805 350{
7c474504 351 volatile int destruct_level; /* 0=none, 1=full, 2=full with checks */
a0d0e21e 352 HV *hv;
8990e307 353
7766f137
GS		 354 /* wait for all pseudo-forked children to finish */
355 PERL_WAIT_FOR_CHILDREN;
356
3280af22 357 destruct_level = PL_perl_destruct_level;
4633a7c4
LW		 358#ifdef DEBUGGING
359 {
360 char *s;
155aba94 361 if ((s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL"))) {
5f05dabc 362 int i = atoi(s);
363 if (destruct_level < i)
364 destruct_level = i;
365 }
4633a7c4
LW		 366 }
367#endif
368
31d77e54
AB		 369
370 if(PL_exit_flags & PERL_EXIT_DESTRUCT_END) {
f3faeb53
AB		 371 dJMPENV;
372 int x = 0;
373
374 JMPENV_PUSH(x);
375 if (PL_endav && !PL_minus_c)
376 call_list(PL_scopestack_ix, PL_endav);
377 JMPENV_POP;
26f423df 378 }
f3faeb53 379 LEAVE;
a0d0e21e
LW		 380 FREETMPS;
381
e00b64d4 382 /* Need to flush since END blocks can produce output */
f13a2bc0 383 my_fflush_all();
e00b64d4 384
62375a60
NIS		 385 if (CALL_FPTR(PL_threadhook)(aTHX)) {
386 /* Threads hook has vetoed further cleanup */
b47cad08 387 return STATUS_NATIVE_EXPORT;
62375a60
NIS		 388 }
389
ff0cee69 390 /* We must account for everything. */
391
392 /* Destroy the main CV and syntax tree */
3280af22 393 if (PL_main_root) {
4e380990
DM		 394 /* ensure comppad/curpad to refer to main's pad */
395 if (CvPADLIST(PL_main_cv)) {
396 PAD_SET_CUR_NOSAVE(CvPADLIST(PL_main_cv), 1);
397 }
3280af22
NIS		 398 op_free(PL_main_root);
399 PL_main_root = Nullop;
a0d0e21e 400 }
3280af22
NIS		 401 PL_curcop = &PL_compiling;
402 PL_main_start = Nullop;
403 SvREFCNT_dec(PL_main_cv);
404 PL_main_cv = Nullcv;
24d3c518 405 PL_dirty = TRUE;
ff0cee69 406
13621cfb
NIS		 407 /* Tell PerlIO we are about to tear things apart in case
408 we have layers which are using resources that should
409 be cleaned up now.
410 */
411
412 PerlIO_destruct(aTHX);
413
3280af22 414 if (PL_sv_objcount) {
a0d0e21e
LW		 415 /*
416 * Try to destruct global references. We do this first so that the
417 * destructors and destructees still exist. Some sv's might remain.
418 * Non-referenced objects are on their own.
419 */
a0d0e21e 420 sv_clean_objs();
bf9cdc68 421 PL_sv_objcount = 0;
8990e307
LW		 422 }
423
5cd24f17 424 /* unhook hooks which will soon be, or use, destroyed data */
3280af22
NIS		 425 SvREFCNT_dec(PL_warnhook);
426 PL_warnhook = Nullsv;
427 SvREFCNT_dec(PL_diehook);
428 PL_diehook = Nullsv;
5cd24f17 429
4b556e6c 430 /* call exit list functions */
3280af22 431 while (PL_exitlistlen-- > 0)
acfe0abc 432 PL_exitlist[PL_exitlistlen].fn(aTHX_ PL_exitlist[PL_exitlistlen].ptr);
4b556e6c 433
3280af22 434 Safefree(PL_exitlist);
4b556e6c 435
1c4916e5
CB		 436 PL_exitlist = NULL;
437 PL_exitlistlen = 0;
438
a0d0e21e 439 if (destruct_level == 0){
8990e307 440
a0d0e21e 441 DEBUG_P(debprofdump());
ac27b0f5 442
56a2bab7
NIS		 443#if defined(PERLIO_LAYERS)
444 /* No more IO - including error messages ! */
445 PerlIO_cleanup(aTHX);
446#endif
447
a0d0e21e 448 /* The exit() function will do everything that needs doing. */
b47cad08 449 return STATUS_NATIVE_EXPORT;
a0d0e21e 450 }
5dd60ef7 451
551a8b83 452 /* jettison our possibly duplicated environment */
4b647fb0
DM		 453 /* if PERL_USE_SAFE_PUTENV is defined environ will not have been copied
454 * so we certainly shouldn't free it here
455 */
2f42fcb0 456#ifndef PERL_MICRO
4b647fb0 457#if defined(USE_ENVIRON_ARRAY) && !defined(PERL_USE_SAFE_PUTENV)
50acdf95 458 if (environ != PL_origenviron && !PL_use_safe_putenv
4efc5df6
GS		 459#ifdef USE_ITHREADS
460 /* only main thread can free environ[0] contents */
461 && PL_curinterp == aTHX
462#endif
463 )
464 {
551a8b83
JH		 465 I32 i;
466
467 for (i = 0; environ[i]; i++)
4b420006 468 safesysfree(environ[i]);
0631ea03 469
4b420006
JH		 470 /* Must use safesysfree() when working with environ. */
471 safesysfree(environ);
551a8b83
JH		 472
473 environ = PL_origenviron;
474 }
475#endif
2f42fcb0 476#endif /* !PERL_MICRO */
551a8b83 477
804ffa60
DM		 478 /* reset so print() ends up where we expect */
479 setdefout(Nullgv);
480
5f8cb046
DM		 481#ifdef USE_ITHREADS
482 /* the syntax tree is shared between clones
483 * so op_free(PL_main_root) only ReREFCNT_dec's
484 * REGEXPs in the parent interpreter
485 * we need to manually ReREFCNT_dec for the clones
486 */
487 {
488 I32 i = AvFILLp(PL_regex_padav) + 1;
489 SV **ary = AvARRAY(PL_regex_padav);
490
491 while (i) {
35061a7e 492 SV *resv = ary[--i];
ba89bb6e 493 REGEXP *re = INT2PTR(REGEXP *,SvIVX(resv));
35061a7e
DM		 494
495 if (SvFLAGS(resv) & SVf_BREAK) {
577e12cc 496 /* this is PL_reg_curpm, already freed
35061a7e
DM		 497 * flag is set in regexec.c:S_regtry
498 */
499 SvFLAGS(resv) &= ~SVf_BREAK;
3a1ee7e8 500 }
1cc8b4c5
AB		 501 else if(SvREPADTMP(resv)) {
502 SvREPADTMP_off(resv);
503 }
35061a7e 504 else {
5f8cb046
DM		 505 ReREFCNT_dec(re);
506 }
507 }
508 }
509 SvREFCNT_dec(PL_regex_padav);
510 PL_regex_padav = Nullav;
511 PL_regex_pad = NULL;
512#endif
513
081fc587
AB		 514 SvREFCNT_dec((SV*) PL_stashcache);
515 PL_stashcache = NULL;
516
5f05dabc 517 /* loosen bonds of global variables */
518
3280af22
NIS		 519 if(PL_rsfp) {
520 (void)PerlIO_close(PL_rsfp);
521 PL_rsfp = Nullfp;
8ebc5c01 522 }
523
524 /* Filters for program text */
3280af22
NIS		 525 SvREFCNT_dec(PL_rsfp_filters);
526 PL_rsfp_filters = Nullav;
8ebc5c01 527
528 /* switches */
3280af22
NIS		 529 PL_preprocess = FALSE;
530 PL_minus_n = FALSE;
531 PL_minus_p = FALSE;
532 PL_minus_l = FALSE;
533 PL_minus_a = FALSE;
534 PL_minus_F = FALSE;
535 PL_doswitches = FALSE;
599cee73 536 PL_dowarn = G_WARN_OFF;
3280af22
NIS		 537 PL_doextract = FALSE;
538 PL_sawampersand = FALSE; /* must save all match strings */
3280af22
NIS		 539 PL_unsafe = FALSE;
540
541 Safefree(PL_inplace);
542 PL_inplace = Nullch;
a7cb1f99 543 SvREFCNT_dec(PL_patchlevel);
3280af22
NIS		 544
545 if (PL_e_script) {
546 SvREFCNT_dec(PL_e_script);
547 PL_e_script = Nullsv;
8ebc5c01 548 }
549
bf9cdc68
RG		 550 PL_perldb = 0;
551
8ebc5c01 552 /* magical thingies */
553
7889fe52
NIS		 554 SvREFCNT_dec(PL_ofs_sv); /* $, */
555 PL_ofs_sv = Nullsv;
5f05dabc 556
7889fe52
NIS		 557 SvREFCNT_dec(PL_ors_sv); /* $\ */
558 PL_ors_sv = Nullsv;
8ebc5c01 559
3280af22
NIS		 560 SvREFCNT_dec(PL_rs); /* $/ */
561 PL_rs = Nullsv;
dc92893f 562
d33b2eba
GS		 563 PL_multiline = 0; /* $* */
564 Safefree(PL_osname); /* $^O */
565 PL_osname = Nullch;
5f05dabc 566
3280af22
NIS		 567 SvREFCNT_dec(PL_statname);
568 PL_statname = Nullsv;
569 PL_statgv = Nullgv;
5f05dabc 570
8ebc5c01 571 /* defgv, aka *_ should be taken care of elsewhere */
572
8ebc5c01 573 /* clean up after study() */
3280af22
NIS		 574 SvREFCNT_dec(PL_lastscream);
575 PL_lastscream = Nullsv;
576 Safefree(PL_screamfirst);
577 PL_screamfirst = 0;
578 Safefree(PL_screamnext);
579 PL_screamnext = 0;
8ebc5c01 580
7d5ea4e7
GS		 581 /* float buffer */
582 Safefree(PL_efloatbuf);
583 PL_efloatbuf = Nullch;
584 PL_efloatsize = 0;
585
8ebc5c01 586 /* startup and shutdown function lists */
3280af22 587 SvREFCNT_dec(PL_beginav);
5a837c8f 588 SvREFCNT_dec(PL_beginav_save);
3280af22 589 SvREFCNT_dec(PL_endav);
7d30b5c4 590 SvREFCNT_dec(PL_checkav);
ece599bd 591 SvREFCNT_dec(PL_checkav_save);
3280af22
NIS		 592 SvREFCNT_dec(PL_initav);
593 PL_beginav = Nullav;
5a837c8f 594 PL_beginav_save = Nullav;
3280af22 595 PL_endav = Nullav;
7d30b5c4 596 PL_checkav = Nullav;
ece599bd 597 PL_checkav_save = Nullav;
3280af22 598 PL_initav = Nullav;
5618dfe8 599
8ebc5c01 600 /* shortcuts just get cleared */
3280af22 601 PL_envgv = Nullgv;
3280af22
NIS		 602 PL_incgv = Nullgv;
603 PL_hintgv = Nullgv;
604 PL_errgv = Nullgv;
605 PL_argvgv = Nullgv;
606 PL_argvoutgv = Nullgv;
607 PL_stdingv = Nullgv;
bf49b057 608 PL_stderrgv = Nullgv;
3280af22
NIS		 609 PL_last_in_gv = Nullgv;
610 PL_replgv = Nullgv;
bf9cdc68
RG		 611 PL_DBgv = Nullgv;
612 PL_DBline = Nullgv;
613 PL_DBsub = Nullgv;
614 PL_DBsingle = Nullsv;
615 PL_DBtrace = Nullsv;
616 PL_DBsignal = Nullsv;
617 PL_DBassertion = Nullsv;
618 PL_DBcv = Nullcv;
619 PL_dbargs = Nullav;
5c831c24 620 PL_debstash = Nullhv;
8ebc5c01 621
7a1c5554
GS		 622 SvREFCNT_dec(PL_argvout_stack);
623 PL_argvout_stack = Nullav;
8ebc5c01 624
5c831c24
GS		 625 SvREFCNT_dec(PL_modglobal);
626 PL_modglobal = Nullhv;
627 SvREFCNT_dec(PL_preambleav);
628 PL_preambleav = Nullav;
629 SvREFCNT_dec(PL_subname);
630 PL_subname = Nullsv;
631 SvREFCNT_dec(PL_linestr);
632 PL_linestr = Nullsv;
633 SvREFCNT_dec(PL_pidstatus);
634 PL_pidstatus = Nullhv;
635 SvREFCNT_dec(PL_toptarget);
636 PL_toptarget = Nullsv;
637 SvREFCNT_dec(PL_bodytarget);
638 PL_bodytarget = Nullsv;
639 PL_formtarget = Nullsv;
640
d33b2eba 641 /* free locale stuff */
b9582b6a 642#ifdef USE_LOCALE_COLLATE
d33b2eba
GS		 643 Safefree(PL_collation_name);
644 PL_collation_name = Nullch;
b9582b6a 645#endif
d33b2eba 646
b9582b6a 647#ifdef USE_LOCALE_NUMERIC
d33b2eba
GS		 648 Safefree(PL_numeric_name);
649 PL_numeric_name = Nullch;
a453c169 650 SvREFCNT_dec(PL_numeric_radix_sv);
bf9cdc68 651 PL_numeric_radix_sv = Nullsv;
b9582b6a 652#endif
d33b2eba 653
5c831c24
GS		 654 /* clear utf8 character classes */
655 SvREFCNT_dec(PL_utf8_alnum);
656 SvREFCNT_dec(PL_utf8_alnumc);
657 SvREFCNT_dec(PL_utf8_ascii);
658 SvREFCNT_dec(PL_utf8_alpha);
659 SvREFCNT_dec(PL_utf8_space);
660 SvREFCNT_dec(PL_utf8_cntrl);
661 SvREFCNT_dec(PL_utf8_graph);
662 SvREFCNT_dec(PL_utf8_digit);
663 SvREFCNT_dec(PL_utf8_upper);
664 SvREFCNT_dec(PL_utf8_lower);
665 SvREFCNT_dec(PL_utf8_print);
666 SvREFCNT_dec(PL_utf8_punct);
667 SvREFCNT_dec(PL_utf8_xdigit);
668 SvREFCNT_dec(PL_utf8_mark);
669 SvREFCNT_dec(PL_utf8_toupper);
4dbdbdc2 670 SvREFCNT_dec(PL_utf8_totitle);
5c831c24 671 SvREFCNT_dec(PL_utf8_tolower);
b4e400f9 672 SvREFCNT_dec(PL_utf8_tofold);
82686b01
JH		 673 SvREFCNT_dec(PL_utf8_idstart);
674 SvREFCNT_dec(PL_utf8_idcont);
5c831c24
GS		 675 PL_utf8_alnum = Nullsv;
676 PL_utf8_alnumc = Nullsv;
677 PL_utf8_ascii = Nullsv;
678 PL_utf8_alpha = Nullsv;
679 PL_utf8_space = Nullsv;
680 PL_utf8_cntrl = Nullsv;
681 PL_utf8_graph = Nullsv;
682 PL_utf8_digit = Nullsv;
683 PL_utf8_upper = Nullsv;
684 PL_utf8_lower = Nullsv;
685 PL_utf8_print = Nullsv;
686 PL_utf8_punct = Nullsv;
687 PL_utf8_xdigit = Nullsv;
688 PL_utf8_mark = Nullsv;
689 PL_utf8_toupper = Nullsv;
690 PL_utf8_totitle = Nullsv;
691 PL_utf8_tolower = Nullsv;
b4e400f9 692 PL_utf8_tofold = Nullsv;
82686b01
JH		 693 PL_utf8_idstart = Nullsv;
694 PL_utf8_idcont = Nullsv;
5c831c24 695
971a9dd3
GS		 696 if (!specialWARN(PL_compiling.cop_warnings))
697 SvREFCNT_dec(PL_compiling.cop_warnings);
5c831c24 698 PL_compiling.cop_warnings = Nullsv;
ac27b0f5
NIS		 699 if (!specialCopIO(PL_compiling.cop_io))
700 SvREFCNT_dec(PL_compiling.cop_io);
701 PL_compiling.cop_io = Nullsv;
05ec9bb3
NIS		 702 CopFILE_free(&PL_compiling);
703 CopSTASH_free(&PL_compiling);
5c831c24 704
a0d0e21e 705 /* Prepare to destruct main symbol table. */
5f05dabc 706
3280af22
NIS		 707 hv = PL_defstash;
708 PL_defstash = 0;
a0d0e21e 709 SvREFCNT_dec(hv);
5c831c24
GS		 710 SvREFCNT_dec(PL_curstname);
711 PL_curstname = Nullsv;
a0d0e21e 712
5a844595
GS		 713 /* clear queued errors */
714 SvREFCNT_dec(PL_errors);
715 PL_errors = Nullsv;
716
a0d0e21e 717 FREETMPS;
0453d815 718 if (destruct_level >= 2 && ckWARN_d(WARN_INTERNAL)) {
3280af22 719 if (PL_scopestack_ix != 0)
9014280d 720 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
0453d815 721 "Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
3280af22
NIS		 722 (long)PL_scopestack_ix);
723 if (PL_savestack_ix != 0)
9014280d 724 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
0453d815 725 "Unbalanced saves: %ld more saves than restores\n",
3280af22
NIS		 726 (long)PL_savestack_ix);
727 if (PL_tmps_floor != -1)
9014280d 728 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced tmps: %ld more allocs than frees\n",
3280af22 729 (long)PL_tmps_floor + 1);
a0d0e21e 730 if (cxstack_ix != -1)
9014280d 731 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced context: %ld more PUSHes than POPs\n",
ff0cee69 732 (long)cxstack_ix + 1);
a0d0e21e 733 }
8990e307
LW		 734
735 /* Now absolutely destruct everything, somehow or other, loops or no. */
d33b2eba 736 SvFLAGS(PL_fdpid) |= SVTYPEMASK; /* don't clean out pid table now */
3280af22 737 SvFLAGS(PL_strtab) |= SVTYPEMASK; /* don't clean out strtab now */
5226ed68
JH		 738
739 /* the 2 is for PL_fdpid and PL_strtab */
740 while (PL_sv_count > 2 && sv_clean_all())
741 ;
742
d33b2eba
GS		 743 SvFLAGS(PL_fdpid) &= ~SVTYPEMASK;
744 SvFLAGS(PL_fdpid) |= SVt_PVAV;
3280af22
NIS		 745 SvFLAGS(PL_strtab) &= ~SVTYPEMASK;
746 SvFLAGS(PL_strtab) |= SVt_PVHV;
d33b2eba 747
d4777f27
GS		 748 AvREAL_off(PL_fdpid); /* no surviving entries */
749 SvREFCNT_dec(PL_fdpid); /* needed in io_close() */
d33b2eba
GS		 750 PL_fdpid = Nullav;
751
6c644e78
GS		 752#ifdef HAVE_INTERP_INTERN
753 sys_intern_clear();
754#endif
755
6e72f9df 756 /* Destruct the global string table. */
757 {
758 /* Yell and reset the HeVAL() slots that are still holding refcounts,
759 * so that sv_free() won't fail on them.
760 */
761 I32 riter;
762 I32 max;
763 HE *hent;
764 HE **array;
765
766 riter = 0;
3280af22
NIS		 767 max = HvMAX(PL_strtab);
768 array = HvARRAY(PL_strtab);
6e72f9df 769 hent = array[0];
770 for (;;) {
0453d815 771 if (hent && ckWARN_d(WARN_INTERNAL)) {
9014280d 772 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
0453d815 773 "Unbalanced string table refcount: (%d) for \"%s\"",
6e72f9df 774 HeVAL(hent) - Nullsv, HeKEY(hent));
775 HeVAL(hent) = Nullsv;
776 hent = HeNEXT(hent);
777 }
778 if (!hent) {
779 if (++riter > max)
780 break;
781 hent = array[riter];
782 }
783 }
784 }
3280af22 785 SvREFCNT_dec(PL_strtab);
6e72f9df 786
e652bb2f 787#ifdef USE_ITHREADS
a0739874
DM		 788 /* free the pointer table used for cloning */
789 ptr_table_free(PL_ptr_table);
bf9cdc68 790 PL_ptr_table = (PTR_TBL_t*)NULL;
53186e96 791#endif
a0739874 792
d33b2eba
GS		 793 /* free special SVs */
794
795 SvREFCNT(&PL_sv_yes) = 0;
796 sv_clear(&PL_sv_yes);
797 SvANY(&PL_sv_yes) = NULL;
4c5e2b0d 798 SvFLAGS(&PL_sv_yes) = 0;
d33b2eba
GS		 799
800 SvREFCNT(&PL_sv_no) = 0;
801 sv_clear(&PL_sv_no);
802 SvANY(&PL_sv_no) = NULL;
4c5e2b0d 803 SvFLAGS(&PL_sv_no) = 0;
01724ea0 804
9f375a43
DM		 805 {
806 int i;
807 for (i=0; i<=2; i++) {
808 SvREFCNT(PERL_DEBUG_PAD(i)) = 0;
809 sv_clear(PERL_DEBUG_PAD(i));
810 SvANY(PERL_DEBUG_PAD(i)) = NULL;
811 SvFLAGS(PERL_DEBUG_PAD(i)) = 0;
812 }
813 }
814
0453d815 815 if (PL_sv_count != 0 && ckWARN_d(WARN_INTERNAL))
9014280d 816 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Scalars leaked: %ld\n", (long)PL_sv_count);
6e72f9df 817
eba0f806
DM		 818#ifdef DEBUG_LEAKING_SCALARS
819 if (PL_sv_count != 0) {
820 SV* sva;
821 SV* sv;
822 register SV* svend;
823
824 for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
825 svend = &sva[SvREFCNT(sva)];
826 for (sv = sva + 1; sv < svend; ++sv) {
827 if (SvTYPE(sv) != SVTYPEMASK) {
a548cda8
DM		 828 PerlIO_printf(Perl_debug_log, "leaked: sv=0x%p"
829 " flags=0x08%"UVxf
830 " refcnt=%"UVuf pTHX__FORMAT "\n",
831 sv, sv->sv_flags, sv->sv_refcnt pTHX__VALUE);
eba0f806
DM		 832 }
833 }
834 }
835 }
836#endif
bf9cdc68 837 PL_sv_count = 0;
eba0f806
DM		 838
839
56a2bab7 840#if defined(PERLIO_LAYERS)
3a1ee7e8
NIS		 841 /* No more IO - including error messages ! */
842 PerlIO_cleanup(aTHX);
843#endif
844
9f4bd222
NIS		 845 /* sv_undef needs to stay immortal until after PerlIO_cleanup
846 as currently layers use it rather than Nullsv as a marker
847 for no arg - and will try and SvREFCNT_dec it.
848 */
849 SvREFCNT(&PL_sv_undef) = 0;
850 SvREADONLY_off(&PL_sv_undef);
851
3280af22 852 Safefree(PL_origfilename);
bf9cdc68 853 PL_origfilename = Nullch;
3280af22 854 Safefree(PL_reg_start_tmp);
bf9cdc68
RG		 855 PL_reg_start_tmp = (char**)NULL;
856 PL_reg_start_tmpl = 0;
5c5e4c24
IZ		 857 if (PL_reg_curpm)
858 Safefree(PL_reg_curpm);
82ba1be6 859 Safefree(PL_reg_poscache);
dd28f7bb 860 free_tied_hv_pool();
3280af22 861 Safefree(PL_op_mask);
cf36064f 862 Safefree(PL_psig_ptr);
bf9cdc68 863 PL_psig_ptr = (SV**)NULL;
cf36064f 864 Safefree(PL_psig_name);
bf9cdc68 865 PL_psig_name = (SV**)NULL;
2c2666fc 866 Safefree(PL_bitcount);
bf9cdc68 867 PL_bitcount = Nullch;
ce08f86c 868 Safefree(PL_psig_pend);
bf9cdc68
RG		 869 PL_psig_pend = (int*)NULL;
870 PL_formfeed = Nullsv;
871 Safefree(PL_ofmt);
872 PL_ofmt = Nullch;
6e72f9df 873 nuke_stacks();
bf9cdc68
RG		 874 PL_tainting = FALSE;
875 PL_taint_warn = FALSE;
3280af22 876 PL_hints = 0; /* Reset hints. Should hints be per-interpreter ? */
bf9cdc68 877 PL_debug = 0;
ac27b0f5 878
a0d0e21e 879 DEBUG_P(debprofdump());
d33b2eba 880
e5dd39fc 881#ifdef USE_REENTRANT_API
10bc17b6 882 Perl_reentrant_free(aTHX);
e5dd39fc
AB		 883#endif
884
612f20c3
GS		 885 sv_free_arenas();
886
fc36a67e 887 /* As the absolutely last thing, free the non-arena SV for mess() */
888
3280af22 889 if (PL_mess_sv) {
9c63abab
GS		 890 /* it could have accumulated taint magic */
891 if (SvTYPE(PL_mess_sv) >= SVt_PVMG) {
892 MAGIC* mg;
893 MAGIC* moremagic;
894 for (mg = SvMAGIC(PL_mess_sv); mg; mg = moremagic) {
895 moremagic = mg->mg_moremagic;
14befaf4
DM		 896 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global
897 && mg->mg_len >= 0)
9c63abab
GS		 898 Safefree(mg->mg_ptr);
899 Safefree(mg);
900 }
901 }
fc36a67e 902 /* we know that type >= SVt_PV */
0c34ef67 903 SvOOK_off(PL_mess_sv);
3280af22
NIS		 904 Safefree(SvPVX(PL_mess_sv));
905 Safefree(SvANY(PL_mess_sv));
906 Safefree(PL_mess_sv);
907 PL_mess_sv = Nullsv;
fc36a67e 908 }
31d77e54 909 return STATUS_NATIVE_EXPORT;
79072805
LW		 910}
911
954c1994
GS		 912/*
913=for apidoc perl_free
914
915Releases a Perl interpreter. See L<perlembed>.
916
917=cut
918*/
919
79072805 920void
0cb96387 921perl_free(pTHXx)
79072805 922{
acfe0abc 923#if defined(WIN32) || defined(NETWARE)
ce3e5b80 924# if defined(PERL_IMPLICIT_SYS)
acfe0abc
GS		 925# ifdef NETWARE
926 void *host = nw_internal_host;
927# else
928 void *host = w32_internal_host;
929# endif
ce3e5b80 930 PerlMem_free(aTHXx);
acfe0abc 931# ifdef NETWARE
011f1a1a 932 nw_delete_internal_host(host);
acfe0abc
GS		 933# else
934 win32_delete_internal_host(host);
935# endif
1c0ca838
GS		 936# else
937 PerlMem_free(aTHXx);
938# endif
acfe0abc
GS		 939#else
940 PerlMem_free(aTHXx);
76e3520e 941#endif
79072805
LW		 942}
943
4b556e6c 944void
864dbfa3 945Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr)
4b556e6c 946{
3280af22
NIS		 947 Renew(PL_exitlist, PL_exitlistlen+1, PerlExitListEntry);
948 PL_exitlist[PL_exitlistlen].fn = fn;
949 PL_exitlist[PL_exitlistlen].ptr = ptr;
950 ++PL_exitlistlen;
4b556e6c
JD		 951}
952
56cf6df8
RGS		 953#ifdef HAS_PROCSELFEXE
954/* This is a function so that we don't hold on to MAXPATHLEN
955 bytes of stack longer than necessary
956 */
957STATIC void
958S_procself_val(pTHX_ SV *sv, char *arg0)
959{
960 char buf[MAXPATHLEN];
961 int len = readlink(PROCSELFEXE_PATH, buf, sizeof(buf) - 1);
962
963 /* On Playstation2 Linux V1.0 (kernel 2.2.1) readlink(/proc/self/exe)
964 includes a spurious NUL which will cause $^X to fail in system
965 or backticks (this will prevent extensions from being built and
966 many tests from working). readlink is not meant to add a NUL.
967 Normal readlink works fine.
968 */
969 if (len > 0 && buf[len-1] == '\0') {
970 len--;
971 }
972
973 /* FreeBSD's implementation is acknowledged to be imperfect, sometimes
974 returning the text "unknown" from the readlink rather than the path
975 to the executable (or returning an error from the readlink). Any valid
976 path has a '/' in it somewhere, so use that to validate the result.
977 See http://www.freebsd.org/cgi/query-pr.cgi?pr=35703
978 */
979 if (len > 0 && memchr(buf, '/', len)) {
980 sv_setpvn(sv,buf,len);
981 }
982 else {
983 sv_setpv(sv,arg0);
984 }
985}
986#endif /* HAS_PROCSELFEXE */
b7975bdd
NC		 987
988STATIC void
989S_set_caret_X(pTHX) {
990 GV* tmpgv = gv_fetchpv("\030",TRUE, SVt_PV); /* $^X */
991 if (tmpgv) {
992#ifdef HAS_PROCSELFEXE
993 S_procself_val(aTHX_ GvSV(tmpgv), PL_origargv[0]);
994#else
995#ifdef OS2
996 sv_setpv(GvSV(tmpgv), os2_execname(aTHX));
997#else
998 sv_setpv(GvSV(tmpgv),PL_origargv[0]);
999#endif
1000#endif
1001 }
1002}
1003
954c1994
GS		 1004/*
1005=for apidoc perl_parse
1006
1007Tells a Perl interpreter to parse a Perl script. See L<perlembed>.
1008
1009=cut
1010*/
1011
79072805 1012int
0cb96387 1013perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env)
8d063cd8 1014{
6224f72b 1015 I32 oldscope;
6224f72b 1016 int ret;
db36c5a1 1017 dJMPENV;
8d063cd8 1018
a687059c
LW		 1019#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
1020#ifdef IAMSUID
1021#undef IAMSUID
cea2e8a9 1022 Perl_croak(aTHX_ "suidperl is no longer needed since the kernel can now execute\n\
a687059c 1023setuid perl scripts securely.\n");
ae3f3efd 1024#endif /* IAMSUID */
a687059c
LW		 1025#endif
1026
b0891165
JH		 1027#if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT)
1028 /* [perl #22371] Algorimic Complexity Attack on Perl 5.6.1, 5.8.0
103dd899 1029 * This MUST be done before any hash stores or fetches take place.
008fb0c0
NC		 1030 * If you set PL_rehash_seed (and assumedly also PL_rehash_seed_set)
1031 * yourself, it is your responsibility to provide a good random seed!
830b38bd 1032 * You can also define PERL_HASH_SEED in compile time, see hv.h. */
008fb0c0
NC		 1033 if (!PL_rehash_seed_set)
1034 PL_rehash_seed = get_hash_seed();
b0891165 1035 {
bed60192
JH		 1036 char *s = PerlEnv_getenv("PERL_HASH_SEED_DEBUG");
1037
1038 if (s) {
1039 int i = atoi(s);
1040
1041 if (i == 1)
1042 PerlIO_printf(Perl_debug_log, "HASH_SEED = %"UVuf"\n",
008fb0c0 1043 PL_rehash_seed);
bed60192 1044 }
b0891165
JH		 1045 }
1046#endif /* #if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT) */
1047
3280af22 1048 PL_origargc = argc;
e2975953 1049 PL_origargv = argv;
a0d0e21e 1050
54bfe034 1051 {
3cb9023d
JH		 1052 /* Set PL_origalen be the sum of the contiguous argv[]
1053 * elements plus the size of the env in case that it is
e9137a8e 1054 * contiguous with the argv[]. This is used in mg.c:Perl_magic_set()
3cb9023d
JH		 1055 * as the maximum modifiable length of $0. In the worst case
1056 * the area we are able to modify is limited to the size of
43c32782 1057 * the original argv[0]. (See below for 'contiguous', though.)
3cb9023d 1058 * --jhi */
84458fbf 1059 char *s = NULL;
54bfe034 1060 int i;
7d8e7db3
JH		 1061 UV mask =
1062 ~(UV)(PTRSIZE == 4 ? 3 : PTRSIZE == 8 ? 7 : PTRSIZE == 16 ? 15 : 0);
43c32782
JH		 1063 /* Do the mask check only if the args seem like aligned. */
1064 UV aligned =
1065 (mask < ~(UV)0) && ((PTR2UV(argv[0]) & mask) == PTR2UV(argv[0]));
1066
1067 /* See if all the arguments are contiguous in memory. Note
1068 * that 'contiguous' is a loose term because some platforms
1069 * align the argv[] and the envp[]. If the arguments look
1070 * like non-aligned, assume that they are 'strictly' or
1071 * 'traditionally' contiguous. If the arguments look like
1072 * aligned, we just check that they are within aligned
1073 * PTRSIZE bytes. As long as no system has something bizarre
1074 * like the argv[] interleaved with some other data, we are
1075 * fine. (Did I just evoke Murphy's Law?) --jhi */
c8941eeb
JH		 1076 if (PL_origargv && PL_origargc >= 1 && (s = PL_origargv[0])) {
1077 while (*s) s++;
1078 for (i = 1; i < PL_origargc; i++) {
1079 if ((PL_origargv[i] == s + 1
43c32782 1080#ifdef OS2
c8941eeb 1081 || PL_origargv[i] == s + 2
43c32782 1082#endif
c8941eeb
JH		 1083 )
1084 ||
1085 (aligned &&
1086 (PL_origargv[i] > s &&
1087 PL_origargv[i] <=
1088 INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)))
1089 )
1090 {
1091 s = PL_origargv[i];
1092 while (*s) s++;
1093 }
1094 else
1095 break;
54bfe034 1096 }
54bfe034 1097 }
3cb9023d 1098 /* Can we grab env area too to be used as the area for $0? */
43c32782
JH		 1099 if (PL_origenviron) {
1100 if ((PL_origenviron[0] == s + 1
1101#ifdef OS2
1102 || (PL_origenviron[0] == s + 9 && (s += 8))
1103#endif
1104 )
1105 ||
1106 (aligned &&
1107 (PL_origenviron[0] > s &&
1108 PL_origenviron[0] <=
1109 INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)))
1110 )
1111 {
1112#ifndef OS2
1113 s = PL_origenviron[0];
1114 while (*s) s++;
1115#endif
1116 my_setenv("NoNe SuCh", Nullch);
1117 /* Force copy of environment. */
1118 for (i = 1; PL_origenviron[i]; i++) {
1119 if (PL_origenviron[i] == s + 1
1120 ||
1121 (aligned &&
1122 (PL_origenviron[i] > s &&
1123 PL_origenviron[i] <=
1124 INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)))
1125 )
1126 {
1127 s = PL_origenviron[i];
1128 while (*s) s++;
1129 }
1130 else
1131 break;
54bfe034 1132 }
43c32782 1133 }
54bfe034 1134 }
284e1220 1135 PL_origalen = s - PL_origargv[0] + 1;
54bfe034
JH		 1136 }
1137
3280af22 1138 if (PL_do_undump) {
a0d0e21e
LW		 1139
1140 /* Come here if running an undumped a.out. */
1141
3280af22
NIS		 1142 PL_origfilename = savepv(argv[0]);
1143 PL_do_undump = FALSE;
a0d0e21e 1144 cxstack_ix = -1; /* start label stack again */
748a9306 1145 init_ids();
b7975bdd
NC		 1146 assert (!PL_tainted);
1147 TAINT;
1148 S_set_caret_X(aTHX);
1149 TAINT_NOT;
a0d0e21e
LW		 1150 init_postdump_symbols(argc,argv,env);
1151 return 0;
1152 }
1153
3280af22 1154 if (PL_main_root) {
3280af22
NIS		 1155 op_free(PL_main_root);
1156 PL_main_root = Nullop;
ff0cee69 1157 }
3280af22
NIS		 1158 PL_main_start = Nullop;
1159 SvREFCNT_dec(PL_main_cv);
1160 PL_main_cv = Nullcv;
79072805 1161
3280af22
NIS		 1162 time(&PL_basetime);
1163 oldscope = PL_scopestack_ix;
599cee73 1164 PL_dowarn = G_WARN_OFF;
f86702cc 1165
14dd3ad8 1166 JMPENV_PUSH(ret);
6224f72b 1167 switch (ret) {
312caa8e 1168 case 0:
14dd3ad8 1169 parse_body(env,xsinit);
7d30b5c4
GS		 1170 if (PL_checkav)
1171 call_list(oldscope, PL_checkav);
14dd3ad8
GS		 1172 ret = 0;
1173 break;
6224f72b
GS		 1174 case 1:
1175 STATUS_ALL_FAILURE;
1176 /* FALL THROUGH */
1177 case 2:
1178 /* my_exit() was called */
3280af22 1179 while (PL_scopestack_ix > oldscope)
6224f72b
GS		 1180 LEAVE;
1181 FREETMPS;
3280af22 1182 PL_curstash = PL_defstash;
7d30b5c4
GS		 1183 if (PL_checkav)
1184 call_list(oldscope, PL_checkav);
14dd3ad8
GS		 1185 ret = STATUS_NATIVE_EXPORT;
1186 break;
6224f72b 1187 case 3:
bf49b057 1188 PerlIO_printf(Perl_error_log, "panic: top_env\n");
14dd3ad8
GS		 1189 ret = 1;
1190 break;
6224f72b 1191 }
14dd3ad8
GS		 1192 JMPENV_POP;
1193 return ret;
1194}
1195
312caa8e 1196STATIC void *
14dd3ad8 1197S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
312caa8e 1198{
312caa8e
CS		 1199 int argc = PL_origargc;
1200 char **argv = PL_origargv;
312caa8e 1201 char *scriptname = NULL;
312caa8e
CS		 1202 VOL bool dosearch = FALSE;
1203 char *validarg = "";
312caa8e
CS		 1204 register SV *sv;
1205 register char *s;
cf756827 1206 char *cddir = Nullch;
312caa8e 1207
ae3f3efd
PS		 1208 PL_fdscript = -1;
1209 PL_suidscript = -1;
3280af22 1210 sv_setpvn(PL_linestr,"",0);
79cb57f6 1211 sv = newSVpvn("",0); /* first used for -I flags */
6224f72b
GS		 1212 SAVEFREESV(sv);
1213 init_main_stash();
54310121 1214
6224f72b
GS		 1215 for (argc--,argv++; argc > 0; argc--,argv++) {
1216 if (argv[0][0] != '-' || !argv[0][1])
1217 break;
1218#ifdef DOSUID
1219 if (*validarg)
1220 validarg = " PHOOEY ";
1221 else
1222 validarg = argv[0];
ae3f3efd
PS		 1223 /*
1224 * Can we rely on the kernel to start scripts with argv[1] set to
1225 * contain all #! line switches (the whole line)? (argv[0] is set to
1226 * the interpreter name, argv[2] to the script name; argv[3] and
1227 * above may contain other arguments.)
1228 */
13281fa4 1229#endif
6224f72b
GS		 1230 s = argv[0]+1;
1231 reswitch:
1232 switch (*s) {
729a02f2 1233 case 'C':
1d5472a9
GS		 1234#ifndef PERL_STRICT_CR
1235 case '\r':
1236#endif
6224f72b
GS		 1237 case ' ':
1238 case '0':
1239 case 'F':
1240 case 'a':
1241 case 'c':
1242 case 'd':
1243 case 'D':
1244 case 'h':
1245 case 'i':
1246 case 'l':
1247 case 'M':
1248 case 'm':
1249 case 'n':
1250 case 'p':
1251 case 's':
1252 case 'u':
1253 case 'U':
1254 case 'v':
599cee73
PM		 1255 case 'W':
1256 case 'X':
6224f72b 1257 case 'w':
06492da6 1258 case 'A':
155aba94 1259 if ((s = moreswitches(s)))
6224f72b
GS		 1260 goto reswitch;
1261 break;
33b78306 1262
1dbad523 1263 case 't':
22f7c9c9 1264 CHECK_MALLOC_TOO_LATE_FOR('t');
317ea90d
MS		 1265 if( !PL_tainting ) {
1266 PL_taint_warn = TRUE;
1267 PL_tainting = TRUE;
1268 }
1269 s++;
1270 goto reswitch;
6224f72b 1271 case 'T':
22f7c9c9 1272 CHECK_MALLOC_TOO_LATE_FOR('T');
3280af22 1273 PL_tainting = TRUE;
317ea90d 1274 PL_taint_warn = FALSE;
6224f72b
GS		 1275 s++;
1276 goto reswitch;
f86702cc 1277
6224f72b 1278 case 'e':
bf4acbe4
GS		 1279#ifdef MACOS_TRADITIONAL
1280 /* ignore -e for Dev:Pseudo argument */
1281 if (argv[1] && !strcmp(argv[1], "Dev:Pseudo"))
e55ac0fa 1282 break;
bf4acbe4 1283#endif
ae3f3efd 1284 forbid_setid("-e");
3280af22 1285 if (!PL_e_script) {
79cb57f6 1286 PL_e_script = newSVpvn("",0);
0cb96387 1287 filter_add(read_e_script, NULL);
6224f72b
GS		 1288 }
1289 if (*++s)
3280af22 1290 sv_catpv(PL_e_script, s);
6224f72b 1291 else if (argv[1]) {
3280af22 1292 sv_catpv(PL_e_script, argv[1]);
6224f72b
GS		 1293 argc--,argv++;
1294 }
1295 else
cea2e8a9 1296 Perl_croak(aTHX_ "No code specified for -e");
3280af22 1297 sv_catpv(PL_e_script, "\n");
6224f72b 1298 break;
afe37c7d 1299
6224f72b
GS		 1300 case 'I': /* -I handled both here and in moreswitches() */
1301 forbid_setid("-I");
1302 if (!*++s && (s=argv[1]) != Nullch) {
1303 argc--,argv++;
1304 }
6224f72b 1305 if (s && *s) {
0df16ed7
GS		 1306 char *p;
1307 STRLEN len = strlen(s);
1308 p = savepvn(s, len);
88fe16b2 1309 incpush(p, TRUE, TRUE, FALSE, FALSE);
0df16ed7
GS		 1310 sv_catpvn(sv, "-I", 2);
1311 sv_catpvn(sv, p, len);
1312 sv_catpvn(sv, " ", 1);
6224f72b 1313 Safefree(p);
0df16ed7
GS		 1314 }
1315 else
a67e862a 1316 Perl_croak(aTHX_ "No directory specified for -I");
6224f72b
GS		 1317 break;
1318 case 'P':
1319 forbid_setid("-P");
3280af22 1320 PL_preprocess = TRUE;
6224f72b
GS		 1321 s++;
1322 goto reswitch;
1323 case 'S':
1324 forbid_setid("-S");
1325 dosearch = TRUE;
1326 s++;
1327 goto reswitch;
1328 case 'V':
3280af22
NIS		 1329 if (!PL_preambleav)
1330 PL_preambleav = newAV();
1331 av_push(PL_preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
6224f72b 1332 if (*++s != ':') {
3280af22 1333 PL_Sv = newSVpv("print myconfig();",0);
6224f72b 1334#ifdef VMS
6b88bc9c 1335 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
6224f72b 1336#else
3280af22 1337 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
6224f72b 1338#endif
3280af22 1339 sv_catpv(PL_Sv,"\" Compile-time options:");
6224f72b 1340# ifdef DEBUGGING
3280af22 1341 sv_catpv(PL_Sv," DEBUGGING");
6224f72b 1342# endif
6224f72b 1343# ifdef MULTIPLICITY
8f872242 1344 sv_catpv(PL_Sv," MULTIPLICITY");
6224f72b 1345# endif
4d1ff10f
AB		 1346# ifdef USE_5005THREADS
1347 sv_catpv(PL_Sv," USE_5005THREADS");
b363f7ed 1348# endif
ac5e8965
JH		 1349# ifdef USE_ITHREADS
1350 sv_catpv(PL_Sv," USE_ITHREADS");
1351# endif
10cc9d2a
JH		 1352# ifdef USE_64_BIT_INT
1353 sv_catpv(PL_Sv," USE_64_BIT_INT");
1354# endif
1355# ifdef USE_64_BIT_ALL
1356 sv_catpv(PL_Sv," USE_64_BIT_ALL");
ac5e8965
JH		 1357# endif
1358# ifdef USE_LONG_DOUBLE
1359 sv_catpv(PL_Sv," USE_LONG_DOUBLE");
1360# endif
53430762
JH		 1361# ifdef USE_LARGE_FILES
1362 sv_catpv(PL_Sv," USE_LARGE_FILES");
1363# endif
ac5e8965
JH		 1364# ifdef USE_SOCKS
1365 sv_catpv(PL_Sv," USE_SOCKS");
1366# endif
b363f7ed
GS		 1367# ifdef PERL_IMPLICIT_CONTEXT
1368 sv_catpv(PL_Sv," PERL_IMPLICIT_CONTEXT");
1369# endif
1370# ifdef PERL_IMPLICIT_SYS
1371 sv_catpv(PL_Sv," PERL_IMPLICIT_SYS");
1372# endif
3280af22 1373 sv_catpv(PL_Sv,"\\n\",");
b363f7ed 1374
6224f72b
GS		 1375#if defined(LOCAL_PATCH_COUNT)
1376 if (LOCAL_PATCH_COUNT > 0) {
1377 int i;
3280af22 1378 sv_catpv(PL_Sv,"\" Locally applied patches:\\n\",");
6224f72b 1379 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
3280af22 1380 if (PL_localpatches[i])
acb03d05
AB		 1381 Perl_sv_catpvf(aTHX_ PL_Sv,"q%c\t%s\n%c,",
1382 0, PL_localpatches[i], 0);
6224f72b
GS		 1383 }
1384 }
1385#endif
cea2e8a9 1386 Perl_sv_catpvf(aTHX_ PL_Sv,"\" Built under %s\\n\"",OSNAME);
6224f72b
GS		 1387#ifdef __DATE__
1388# ifdef __TIME__
cea2e8a9 1389 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
6224f72b 1390# else
cea2e8a9 1391 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled on %s\\n\"",__DATE__);
6224f72b
GS		 1392# endif
1393#endif
3280af22 1394 sv_catpv(PL_Sv, "; \
6224f72b 1395$\"=\"\\n \"; \
69fcd688
JH		 1396@env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; ");
1397#ifdef __CYGWIN__
1398 sv_catpv(PL_Sv,"\
1399push @env, \"CYGWIN=\\\"$ENV{CYGWIN}\\\"\";");
1400#endif
1401 sv_catpv(PL_Sv, "\
6224f72b
GS		 1402print \" \\%ENV:\\n @env\\n\" if @env; \
1403print \" \\@INC:\\n @INC\\n\";");
1404 }
1405 else {
3280af22
NIS		 1406 PL_Sv = newSVpv("config_vars(qw(",0);
1407 sv_catpv(PL_Sv, ++s);
1408 sv_catpv(PL_Sv, "))");
6224f72b
GS		 1409 s += strlen(s);
1410 }
3280af22 1411 av_push(PL_preambleav, PL_Sv);
6224f72b
GS		 1412 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
1413 goto reswitch;
1414 case 'x':
3280af22 1415 PL_doextract = TRUE;
6224f72b
GS		 1416 s++;
1417 if (*s)
f4c556ac 1418 cddir = s;
6224f72b
GS		 1419 break;
1420 case 0:
1421 break;
1422 case '-':
1423 if (!*++s || isSPACE(*s)) {
1424 argc--,argv++;
1425 goto switch_end;
1426 }
1427 /* catch use of gnu style long options */
1428 if (strEQ(s, "version")) {
1429 s = "v";
1430 goto reswitch;
1431 }
1432 if (strEQ(s, "help")) {
1433 s = "h";
1434 goto reswitch;
1435 }
1436 s--;
1437 /* FALL THROUGH */
1438 default:
cea2e8a9 1439 Perl_croak(aTHX_ "Unrecognized switch: -%s (-h will show valid options)",s);
8d063cd8
LW		 1440 }
1441 }
6224f72b 1442 switch_end:
54310121 1443
f675dbe5
CB		 1444 if (
1445#ifndef SECURE_INTERNAL_GETENV
1446 !PL_tainting &&
1447#endif
cf756827 1448 (s = PerlEnv_getenv("PERL5OPT")))
0df16ed7 1449 {
cf756827 1450 char *popt = s;
74288ac8
GS		 1451 while (isSPACE(*s))
1452 s++;
317ea90d 1453 if (*s == '-' && *(s+1) == 'T') {
22f7c9c9 1454 CHECK_MALLOC_TOO_LATE_FOR('T');
74288ac8 1455 PL_tainting = TRUE;
317ea90d
MS		 1456 PL_taint_warn = FALSE;
1457 }
74288ac8 1458 else {
cf756827 1459 char *popt_copy = Nullch;
74288ac8 1460 while (s && *s) {
4ea8f8fb 1461 char *d;
74288ac8
GS		 1462 while (isSPACE(*s))
1463 s++;
1464 if (*s == '-') {
1465 s++;
1466 if (isSPACE(*s))
1467 continue;
1468 }
4ea8f8fb 1469 d = s;
74288ac8
GS		 1470 if (!*s)
1471 break;
06492da6 1472 if (!strchr("DIMUdmtwA", *s))
cea2e8a9 1473 Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s);
4ea8f8fb
MS		 1474 while (++s && *s) {
1475 if (isSPACE(*s)) {
cf756827
GS		 1476 if (!popt_copy) {
1477 popt_copy = SvPVX(sv_2mortal(newSVpv(popt,0)));
1478 s = popt_copy + (s - popt);
1479 d = popt_copy + (d - popt);
1480 }
4ea8f8fb
MS		 1481 *s++ = '\0';
1482 break;
1483 }
1484 }
1c4db469 1485 if (*d == 't') {
317ea90d
MS		 1486 if( !PL_tainting ) {
1487 PL_taint_warn = TRUE;
1488 PL_tainting = TRUE;
1489 }
1c4db469
RGS		 1490 } else {
1491 moreswitches(d);
1492 }
6224f72b 1493 }
6224f72b
GS		 1494 }
1495 }
a0d0e21e 1496
317ea90d
MS		 1497 if (PL_taint_warn && PL_dowarn != G_WARN_ALL_OFF) {
1498 PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
1499 }
1500
6224f72b
GS		 1501 if (!scriptname)
1502 scriptname = argv[0];
3280af22 1503 if (PL_e_script) {
6224f72b
GS		 1504 argc++,argv--;
1505 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
1506 }
1507 else if (scriptname == Nullch) {
1508#ifdef MSDOS
1509 if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
1510 moreswitches("h");
1511#endif
1512 scriptname = "-";
1513 }
1514
b7975bdd
NC		 1515 /* Set $^X early so that it can be used for relocatable paths in @INC */
1516 assert (!PL_tainted);
1517 TAINT;
1518 S_set_caret_X(aTHX);
1519 TAINT_NOT;
6224f72b
GS		 1520 init_perllib();
1521
c5cccb17 1522 open_script(scriptname,dosearch,sv);
6224f72b 1523
c5cccb17 1524 validate_suid(validarg, scriptname);
6224f72b 1525
64ca3a65 1526#ifndef PERL_MICRO
0b5b802d
GS		 1527#if defined(SIGCHLD) || defined(SIGCLD)
1528 {
1529#ifndef SIGCHLD
1530# define SIGCHLD SIGCLD
1531#endif
1532 Sighandler_t sigstate = rsignal_state(SIGCHLD);
1533 if (sigstate == SIG_IGN) {
1534 if (ckWARN(WARN_SIGNAL))
9014280d 1535 Perl_warner(aTHX_ packWARN(WARN_SIGNAL),
0b5b802d
GS		 1536 "Can't ignore signal CHLD, forcing to default");
1537 (void)rsignal(SIGCHLD, (Sighandler_t)SIG_DFL);
1538 }
1539 }
1540#endif
64ca3a65 1541#endif
0b5b802d 1542
bf4acbe4
GS		 1543#ifdef MACOS_TRADITIONAL
1544 if (PL_doextract || gMacPerl_AlwaysExtract) {
1545#else
f4c556ac 1546 if (PL_doextract) {
bf4acbe4 1547#endif
6224f72b 1548 find_beginning();
f4c556ac
GS		 1549 if (cddir && PerlDir_chdir(cddir) < 0)
1550 Perl_croak(aTHX_ "Can't chdir to %s",cddir);
1551
1552 }
6224f72b 1553
3280af22
NIS		 1554 PL_main_cv = PL_compcv = (CV*)NEWSV(1104,0);
1555 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
1556 CvUNIQUE_on(PL_compcv);
1557
dd2155a4 1558 CvPADLIST(PL_compcv) = pad_new(0);
4d1ff10f 1559#ifdef USE_5005THREADS
533c011a
NIS		 1560 CvOWNER(PL_compcv) = 0;
1561 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
1562 MUTEX_INIT(CvMUTEXP(PL_compcv));
4d1ff10f 1563#endif /* USE_5005THREADS */
6224f72b 1564
0c4f7ff0 1565 boot_core_PerlIO();
6224f72b 1566 boot_core_UNIVERSAL();
09bef843 1567 boot_core_xsutils();
6224f72b
GS		 1568
1569 if (xsinit)
acfe0abc 1570 (*xsinit)(aTHX); /* in case linked C routines want magical variables */
64ca3a65 1571#ifndef PERL_MICRO
ed79a026 1572#if defined(VMS) || defined(WIN32) || defined(DJGPP) || defined(__CYGWIN__) || defined(EPOC)
c5be433b 1573 init_os_extras();
6224f72b 1574#endif
64ca3a65 1575#endif
6224f72b 1576
29209bc5 1577#ifdef USE_SOCKS
1b9c9cf5
DH		 1578# ifdef HAS_SOCKS5_INIT
1579 socks5_init(argv[0]);
1580# else
29209bc5 1581 SOCKSinit(argv[0]);
1b9c9cf5 1582# endif
ac27b0f5 1583#endif
29209bc5 1584
6224f72b
GS		 1585 init_predump_symbols();
1586 /* init_postdump_symbols not currently designed to be called */
1587 /* more than once (ENV isn't cleared first, for example) */
1588 /* But running with -u leaves %ENV & @ARGV undefined! XXX */
3280af22 1589 if (!PL_do_undump)
6224f72b
GS		 1590 init_postdump_symbols(argc,argv,env);
1591
a05d7ebb
JH		 1592 /* PL_unicode is turned on by -C or by $ENV{PERL_UNICODE}.
1593 * PL_utf8locale is conditionally turned on by
085a54d9 1594 * locale.c:Perl_init_i18nl10n() if the environment
a05d7ebb 1595 * look like the user wants to use UTF-8. */
06e66572
JH		 1596 if (PL_unicode) {
1597 /* Requires init_predump_symbols(). */
a05d7ebb 1598 if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) {
06e66572
JH		 1599 IO* io;
1600 PerlIO* fp;
1601 SV* sv;
1602
a05d7ebb 1603 /* Turn on UTF-8-ness on STDIN, STDOUT, STDERR
06e66572 1604 * and the default open disciplines. */
a05d7ebb
JH		 1605 if ((PL_unicode & PERL_UNICODE_STDIN_FLAG) &&
1606 PL_stdingv && (io = GvIO(PL_stdingv)) &&
1607 (fp = IoIFP(io)))
1608 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
1609 if ((PL_unicode & PERL_UNICODE_STDOUT_FLAG) &&
1610 PL_defoutgv && (io = GvIO(PL_defoutgv)) &&
1611 (fp = IoOFP(io)))
1612 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
1613 if ((PL_unicode & PERL_UNICODE_STDERR_FLAG) &&
1614 PL_stderrgv && (io = GvIO(PL_stderrgv)) &&
1615 (fp = IoOFP(io)))
1616 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
1617 if ((PL_unicode & PERL_UNICODE_INOUT_FLAG) &&
1618 (sv = GvSV(gv_fetchpv("\017PEN", TRUE, SVt_PV)))) {
1619 U32 in = PL_unicode & PERL_UNICODE_IN_FLAG;
1620 U32 out = PL_unicode & PERL_UNICODE_OUT_FLAG;
1621 if (in) {
1622 if (out)
1623 sv_setpvn(sv, ":utf8\0:utf8", 11);
1624 else
1625 sv_setpvn(sv, ":utf8\0", 6);
1626 }
1627 else if (out)
1628 sv_setpvn(sv, "\0:utf8", 6);
1629 SvSETMAGIC(sv);
1630 }
b310b053
JH		 1631 }
1632 }
1633
4ffa73a3
JH		 1634 if ((s = PerlEnv_getenv("PERL_SIGNALS"))) {
1635 if (strEQ(s, "unsafe"))
1636 PL_signals |= PERL_SIGNALS_UNSAFE_FLAG;
1637 else if (strEQ(s, "safe"))
1638 PL_signals &= ~PERL_SIGNALS_UNSAFE_FLAG;
1639 else
1640 Perl_croak(aTHX_ "PERL_SIGNALS illegal: \"%s\"", s);
1641 }
1642
6224f72b
GS		 1643 init_lexer();
1644
1645 /* now parse the script */
1646
93189314 1647 SETERRNO(0,SS_NORMAL);
3280af22 1648 PL_error_count = 0;
bf4acbe4
GS		 1649#ifdef MACOS_TRADITIONAL
1650 if (gMacPerl_SyntaxError = (yyparse() || PL_error_count)) {
1651 if (PL_minus_c)
1652 Perl_croak(aTHX_ "%s had compilation errors.\n", MacPerl_MPWFileName(PL_origfilename));
1653 else {
1654 Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
1655 MacPerl_MPWFileName(PL_origfilename));
1656 }
1657 }
1658#else
3280af22
NIS		 1659 if (yyparse() || PL_error_count) {
1660 if (PL_minus_c)
cea2e8a9 1661 Perl_croak(aTHX_ "%s had compilation errors.\n", PL_origfilename);
6224f72b 1662 else {
cea2e8a9 1663 Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
097ee67d 1664 PL_origfilename);
6224f72b
GS		 1665 }
1666 }
bf4acbe4 1667#endif
57843af0 1668 CopLINE_set(PL_curcop, 0);
3280af22
NIS		 1669 PL_curstash = PL_defstash;
1670 PL_preprocess = FALSE;
1671 if (PL_e_script) {
1672 SvREFCNT_dec(PL_e_script);
1673 PL_e_script = Nullsv;
6224f72b
GS		 1674 }
1675
3280af22 1676 if (PL_do_undump)
6224f72b
GS		 1677 my_unexec();
1678
57843af0
GS		 1679 if (isWARN_ONCE) {
1680 SAVECOPFILE(PL_curcop);
1681 SAVECOPLINE(PL_curcop);
3280af22 1682 gv_check(PL_defstash);
57843af0 1683 }
6224f72b
GS		 1684
1685 LEAVE;
1686 FREETMPS;
1687
1688#ifdef MYMALLOC
1689 if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
1690 dump_mstats("after compilation:");
1691#endif
1692
1693 ENTER;
3280af22 1694 PL_restartop = 0;
312caa8e 1695 return NULL;
6224f72b
GS		 1696}
1697
954c1994
GS		 1698/*
1699=for apidoc perl_run
1700
1701Tells a Perl interpreter to run. See L<perlembed>.
1702
1703=cut
1704*/
1705
6224f72b 1706int
0cb96387 1707perl_run(pTHXx)
6224f72b 1708{
6224f72b 1709 I32 oldscope;
14dd3ad8 1710 int ret = 0;
db36c5a1 1711 dJMPENV;
6224f72b 1712
3280af22 1713 oldscope = PL_scopestack_ix;
96e176bf
CL		 1714#ifdef VMS
1715 VMSISH_HUSHED = 0;
1716#endif
6224f72b 1717
14dd3ad8 1718 JMPENV_PUSH(ret);
6224f72b
GS		 1719 switch (ret) {
1720 case 1:
1721 cxstack_ix = -1; /* start context stack again */
312caa8e 1722 goto redo_body;
14dd3ad8 1723 case 0: /* normal completion */
14dd3ad8
GS		 1724 redo_body:
1725 run_body(oldscope);
14dd3ad8
GS		 1726 /* FALL THROUGH */
1727 case 2: /* my_exit() */
3280af22 1728 while (PL_scopestack_ix > oldscope)
6224f72b
GS		 1729 LEAVE;
1730 FREETMPS;
3280af22 1731 PL_curstash = PL_defstash;
3a1ee7e8 1732 if (!(PL_exit_flags & PERL_EXIT_DESTRUCT_END) &&
31d77e54
AB		 1733 PL_endav && !PL_minus_c)
1734 call_list(oldscope, PL_endav);
6224f72b
GS		 1735#ifdef MYMALLOC
1736 if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
1737 dump_mstats("after execution: ");
1738#endif
14dd3ad8
GS		 1739 ret = STATUS_NATIVE_EXPORT;
1740 break;
6224f72b 1741 case 3:
312caa8e
CS		 1742 if (PL_restartop) {
1743 POPSTACK_TO(PL_mainstack);
1744 goto redo_body;
6224f72b 1745 }
bf49b057 1746 PerlIO_printf(Perl_error_log, "panic: restartop\n");
312caa8e 1747 FREETMPS;
14dd3ad8
GS		 1748 ret = 1;
1749 break;
6224f72b
GS		 1750 }
1751
14dd3ad8
GS		 1752 JMPENV_POP;
1753 return ret;
312caa8e
CS		 1754}
1755
14dd3ad8
GS		 1756
1757STATIC void *
1758S_run_body(pTHX_ I32 oldscope)
1759{
6224f72b 1760 DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
3280af22 1761 PL_sawampersand ? "Enabling" : "Omitting"));
6224f72b 1762
3280af22 1763 if (!PL_restartop) {
6224f72b 1764 DEBUG_x(dump_all());
ecae49c0
NC		 1765 if (!DEBUG_q_TEST)
1766 PERL_DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
b900a521
JH		 1767 DEBUG_S(PerlIO_printf(Perl_debug_log, "main thread is 0x%"UVxf"\n",
1768 PTR2UV(thr)));
6224f72b 1769
3280af22 1770 if (PL_minus_c) {
bf4acbe4 1771#ifdef MACOS_TRADITIONAL
e69a2255
JH		 1772 PerlIO_printf(Perl_error_log, "%s%s syntax OK\n",
1773 (gMacPerl_ErrorFormat ? "# " : ""),
1774 MacPerl_MPWFileName(PL_origfilename));
bf4acbe4 1775#else
bf49b057 1776 PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename);
bf4acbe4 1777#endif
6224f72b
GS		 1778 my_exit(0);
1779 }
3280af22 1780 if (PERLDB_SINGLE && PL_DBsingle)
ac27b0f5 1781 sv_setiv(PL_DBsingle, 1);
3280af22
NIS		 1782 if (PL_initav)
1783 call_list(oldscope, PL_initav);
6224f72b
GS		 1784 }
1785
1786 /* do it */
1787
3280af22 1788 if (PL_restartop) {
533c011a 1789 PL_op = PL_restartop;
3280af22 1790 PL_restartop = 0;
cea2e8a9 1791 CALLRUNOPS(aTHX);
6224f72b 1792 }
3280af22
NIS		 1793 else if (PL_main_start) {
1794 CvDEPTH(PL_main_cv) = 1;
533c011a 1795 PL_op = PL_main_start;
cea2e8a9 1796 CALLRUNOPS(aTHX);
6224f72b
GS		 1797 }
1798
f6b3007c
JH		 1799 my_exit(0);
1800 /* NOTREACHED */
312caa8e 1801 return NULL;
6224f72b
GS		 1802}
1803
954c1994 1804/*
ccfc67b7
JH		 1805=head1 SV Manipulation Functions
1806
954c1994
GS		 1807=for apidoc p||get_sv
1808
1809Returns the SV of the specified Perl scalar. If C<create> is set and the
1810Perl variable does not exist then it will be created. If C<create> is not
1811set and the variable does not exist then NULL is returned.
1812
1813=cut
1814*/
1815
6224f72b 1816SV*
864dbfa3 1817Perl_get_sv(pTHX_ const char *name, I32 create)
6224f72b
GS		 1818{
1819 GV *gv;
4d1ff10f 1820#ifdef USE_5005THREADS
6224f72b
GS		 1821 if (name[1] == '\0' && !isALPHA(name[0])) {
1822 PADOFFSET tmp = find_threadsv(name);
411caa50 1823 if (tmp != NOT_IN_PAD)
6224f72b 1824 return THREADSV(tmp);
6224f72b 1825 }
4d1ff10f 1826#endif /* USE_5005THREADS */
6224f72b
GS		 1827 gv = gv_fetchpv(name, create, SVt_PV);
1828 if (gv)
1829 return GvSV(gv);
1830 return Nullsv;
1831}
1832
954c1994 1833/*
ccfc67b7
JH		 1834=head1 Array Manipulation Functions
1835
954c1994
GS		 1836=for apidoc p||get_av
1837
1838Returns the AV of the specified Perl array. If C<create> is set and the
1839Perl variable does not exist then it will be created. If C<create> is not
1840set and the variable does not exist then NULL is returned.
1841
1842=cut
1843*/
1844
6224f72b 1845AV*
864dbfa3 1846Perl_get_av(pTHX_ const char *name, I32 create)
6224f72b
GS		 1847{
1848 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
1849 if (create)
1850 return GvAVn(gv);
1851 if (gv)
1852 return GvAV(gv);
1853 return Nullav;
1854}
1855
954c1994 1856/*
ccfc67b7
JH		 1857=head1 Hash Manipulation Functions
1858
954c1994
GS		 1859=for apidoc p||get_hv
1860
1861Returns the HV of the specified Perl hash. If C<create> is set and the
1862Perl variable does not exist then it will be created. If C<create> is not
1863set and the variable does not exist then NULL is returned.
1864
1865=cut
1866*/
1867
6224f72b 1868HV*
864dbfa3 1869Perl_get_hv(pTHX_ const char *name, I32 create)
6224f72b 1870{
a0d0e21e
LW		 1871 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
1872 if (create)
1873 return GvHVn(gv);
1874 if (gv)
1875 return GvHV(gv);
1876 return Nullhv;
1877}
1878
954c1994 1879/*
ccfc67b7
JH		 1880=head1 CV Manipulation Functions
1881
954c1994
GS		 1882=for apidoc p||get_cv
1883
1884Returns the CV of the specified Perl subroutine. If C<create> is set and
1885the Perl subroutine does not exist then it will be declared (which has the
1886same effect as saying C<sub name;>). If C<create> is not set and the
1887subroutine does not exist then NULL is returned.
1888
1889=cut
1890*/
1891
a0d0e21e 1892CV*
864dbfa3 1893Perl_get_cv(pTHX_ const char *name, I32 create)
a0d0e21e
LW		 1894{
1895 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
b099ddc0 1896 /* XXX unsafe for threads if eval_owner isn't held */
f6ec51f7
GS		 1897 /* XXX this is probably not what they think they're getting.
1898 * It has the same effect as "sub name;", i.e. just a forward
1899 * declaration! */
8ebc5c01 1900 if (create && !GvCVu(gv))
774d564b 1901 return newSUB(start_subparse(FALSE, 0),
a0d0e21e 1902 newSVOP(OP_CONST, 0, newSVpv(name,0)),
4633a7c4 1903 Nullop,
a0d0e21e
LW		 1904 Nullop);
1905 if (gv)
8ebc5c01 1906 return GvCVu(gv);
a0d0e21e
LW		 1907 return Nullcv;
1908}
1909
79072805
LW		 1910/* Be sure to refetch the stack pointer after calling these routines. */
1911
954c1994 1912/*
ccfc67b7
JH		 1913
1914=head1 Callback Functions
1915
954c1994
GS		 1916=for apidoc p||call_argv
1917
1918Performs a callback to the specified Perl sub. See L<perlcall>.
1919
1920=cut
1921*/
1922
a0d0e21e 1923I32
864dbfa3 1924Perl_call_argv(pTHX_ const char *sub_name, I32 flags, register char **argv)
ac27b0f5 1925
8ac85365
NIS		 1926 /* See G_* flags in cop.h */
1927 /* null terminated arg list */
8990e307 1928{
a0d0e21e 1929 dSP;
8990e307 1930
924508f0 1931 PUSHMARK(SP);
a0d0e21e 1932 if (argv) {
8990e307 1933 while (*argv) {
a0d0e21e 1934 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
8990e307
LW		 1935 argv++;
1936 }
a0d0e21e 1937 PUTBACK;
8990e307 1938 }
864dbfa3 1939 return call_pv(sub_name, flags);
8990e307
LW		 1940}
1941
954c1994
GS		 1942/*
1943=for apidoc p||call_pv
1944
1945Performs a callback to the specified Perl sub. See L<perlcall>.
1946
1947=cut
1948*/
1949
a0d0e21e 1950I32
864dbfa3 1951Perl_call_pv(pTHX_ const char *sub_name, I32 flags)
8ac85365
NIS		 1952 /* name of the subroutine */
1953 /* See G_* flags in cop.h */
a0d0e21e 1954{
864dbfa3 1955 return call_sv((SV*)get_cv(sub_name, TRUE), flags);
a0d0e21e
LW		 1956}
1957
954c1994
GS		 1958/*
1959=for apidoc p||call_method
1960
1961Performs a callback to the specified Perl method. The blessed object must
1962be on the stack. See L<perlcall>.
1963
1964=cut
1965*/
1966
a0d0e21e 1967I32
864dbfa3 1968Perl_call_method(pTHX_ const char *methname, I32 flags)
8ac85365
NIS		 1969 /* name of the subroutine */
1970 /* See G_* flags in cop.h */
a0d0e21e 1971{
968b3946 1972 return call_sv(sv_2mortal(newSVpv(methname,0)), flags | G_METHOD);
a0d0e21e
LW		 1973}
1974
1975/* May be called with any of a CV, a GV, or an SV containing the name. */
954c1994
GS		 1976/*
1977=for apidoc p||call_sv
1978
1979Performs a callback to the Perl sub whose name is in the SV. See
1980L<perlcall>.
1981
1982=cut
1983*/
1984
a0d0e21e 1985I32
864dbfa3 1986Perl_call_sv(pTHX_ SV *sv, I32 flags)
8ac85365 1987 /* See G_* flags in cop.h */
a0d0e21e 1988{
924508f0 1989 dSP;
a0d0e21e 1990 LOGOP myop; /* fake syntax tree node */
968b3946 1991 UNOP method_op;
aa689395 1992 I32 oldmark;
13689cfe 1993 volatile I32 retval = 0;
a0d0e21e 1994 I32 oldscope;
54310121 1995 bool oldcatch = CATCH_GET;
6224f72b 1996 int ret;
533c011a 1997 OP* oldop = PL_op;
db36c5a1 1998 dJMPENV;
1e422769 1999
a0d0e21e
LW		 2000 if (flags & G_DISCARD) {
2001 ENTER;
2002 SAVETMPS;
2003 }
2004
aa689395 2005 Zero(&myop, 1, LOGOP);
54310121 2006 myop.op_next = Nullop;
f51d4af5 2007 if (!(flags & G_NOARGS))
aa689395 2008 myop.op_flags |= OPf_STACKED;
54310121 2009 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
2010 (flags & G_ARRAY) ? OPf_WANT_LIST :
2011 OPf_WANT_SCALAR);
462e5cf6 2012 SAVEOP();
533c011a 2013 PL_op = (OP*)&myop;
aa689395 2014
3280af22
NIS		 2015 EXTEND(PL_stack_sp, 1);
2016 *++PL_stack_sp = sv;
aa689395 2017 oldmark = TOPMARK;
3280af22 2018 oldscope = PL_scopestack_ix;
a0d0e21e 2019
3280af22 2020 if (PERLDB_SUB && PL_curstash != PL_debstash
36477c24 2021 /* Handle first BEGIN of -d. */
3280af22 2022 && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub)))
36477c24 2023 /* Try harder, since this may have been a sighandler, thus
2024 * curstash may be meaningless. */
3280af22 2025 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != PL_debstash)
491527d0 2026 && !(flags & G_NODEBUG))
533c011a 2027 PL_op->op_private |= OPpENTERSUB_DB;
a0d0e21e 2028
968b3946
GS		 2029 if (flags & G_METHOD) {
2030 Zero(&method_op, 1, UNOP);
2031 method_op.op_next = PL_op;
2032 method_op.op_ppaddr = PL_ppaddr[OP_METHOD];
2033 myop.op_ppaddr = PL_ppaddr[OP_ENTERSUB];
f39d0b86 2034 PL_op = (OP*)&method_op;
968b3946
GS		 2035 }
2036
312caa8e 2037 if (!(flags & G_EVAL)) {
0cdb2077 2038 CATCH_SET(TRUE);
14dd3ad8 2039 call_body((OP*)&myop, FALSE);
312caa8e 2040 retval = PL_stack_sp - (PL_stack_base + oldmark);
0253cb41 2041 CATCH_SET(oldcatch);
312caa8e
CS		 2042 }
2043 else {
d78bda3d 2044 myop.op_other = (OP*)&myop;
3280af22 2045 PL_markstack_ptr--;
4633a7c4
LW		 2046 /* we're trying to emulate pp_entertry() here */
2047 {
c09156bb 2048 register PERL_CONTEXT *cx;
54310121 2049 I32 gimme = GIMME_V;
ac27b0f5 2050
4633a7c4
LW		 2051 ENTER;
2052 SAVETMPS;
ac27b0f5 2053
1d76a5c3 2054 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
4633a7c4 2055 PUSHEVAL(cx, 0, 0);
533c011a 2056 PL_eval_root = PL_op; /* Only needed so that goto works right. */
ac27b0f5 2057
faef0170 2058 PL_in_eval = EVAL_INEVAL;
4633a7c4 2059 if (flags & G_KEEPERR)
faef0170 2060 PL_in_eval |= EVAL_KEEPERR;
4633a7c4 2061 else
38a03e6e 2062 sv_setpv(ERRSV,"");
4633a7c4 2063 }
3280af22 2064 PL_markstack_ptr++;
a0d0e21e 2065
14dd3ad8 2066 JMPENV_PUSH(ret);
6224f72b
GS		 2067 switch (ret) {
2068 case 0:
14dd3ad8
GS		 2069 redo_body:
2070 call_body((OP*)&myop, FALSE);
312caa8e
CS		 2071 retval = PL_stack_sp - (PL_stack_base + oldmark);
2072 if (!(flags & G_KEEPERR))
2073 sv_setpv(ERRSV,"");
a0d0e21e 2074 break;
6224f72b 2075 case 1:
f86702cc 2076 STATUS_ALL_FAILURE;
a0d0e21e 2077 /* FALL THROUGH */
6224f72b 2078 case 2:
a0d0e21e 2079 /* my_exit() was called */
3280af22 2080 PL_curstash = PL_defstash;
a0d0e21e 2081 FREETMPS;
14dd3ad8 2082 JMPENV_POP;
cc3604b1 2083 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
cea2e8a9 2084 Perl_croak(aTHX_ "Callback called exit");
f86702cc 2085 my_exit_jump();
a0d0e21e 2086 /* NOTREACHED */
6224f72b 2087 case 3:
3280af22 2088 if (PL_restartop) {
533c011a 2089 PL_op = PL_restartop;
3280af22 2090 PL_restartop = 0;
312caa8e 2091 goto redo_body;
a0d0e21e 2092 }
3280af22 2093 PL_stack_sp = PL_stack_base + oldmark;
a0d0e21e
LW		 2094 if (flags & G_ARRAY)
2095 retval = 0;
2096 else {
2097 retval = 1;
3280af22 2098 *++PL_stack_sp = &PL_sv_undef;
a0d0e21e 2099 }
312caa8e 2100 break;
a0d0e21e 2101 }
a0d0e21e 2102
3280af22 2103 if (PL_scopestack_ix > oldscope) {
a0a2876f
LW		 2104 SV **newsp;
2105 PMOP *newpm;
2106 I32 gimme;
c09156bb 2107 register PERL_CONTEXT *cx;
a0a2876f
LW		 2108 I32 optype;
2109
2110 POPBLOCK(cx,newpm);
2111 POPEVAL(cx);
3280af22 2112 PL_curpm = newpm;
a0a2876f 2113 LEAVE;
a0d0e21e 2114 }
14dd3ad8 2115 JMPENV_POP;
a0d0e21e 2116 }
1e422769 2117
a0d0e21e 2118 if (flags & G_DISCARD) {
3280af22 2119 PL_stack_sp = PL_stack_base + oldmark;
a0d0e21e
LW		 2120 retval = 0;
2121 FREETMPS;
2122 LEAVE;
2123 }
533c011a 2124 PL_op = oldop;
a0d0e21e
LW		 2125 return retval;
2126}
2127
312caa8e 2128STATIC void
14dd3ad8 2129S_call_body(pTHX_ OP *myop, int is_eval)
312caa8e 2130{
312caa8e
CS		 2131 if (PL_op == myop) {
2132 if (is_eval)
f807eda9 2133 PL_op = Perl_pp_entereval(aTHX); /* this doesn't do a POPMARK */
312caa8e 2134 else
f807eda9 2135 PL_op = Perl_pp_entersub(aTHX); /* this does */
312caa8e
CS		 2136 }
2137 if (PL_op)
cea2e8a9 2138 CALLRUNOPS(aTHX);
312caa8e
CS		 2139}
2140
6e72f9df 2141/* Eval a string. The G_EVAL flag is always assumed. */
8990e307 2142
954c1994
GS		 2143/*
2144=for apidoc p||eval_sv
2145
2146Tells Perl to C<eval> the string in the SV.
2147
2148=cut
2149*/
2150
a0d0e21e 2151I32
864dbfa3 2152Perl_eval_sv(pTHX_ SV *sv, I32 flags)
ac27b0f5 2153
8ac85365 2154 /* See G_* flags in cop.h */
a0d0e21e 2155{
924508f0 2156 dSP;
a0d0e21e 2157 UNOP myop; /* fake syntax tree node */
8fa7f367 2158 volatile I32 oldmark = SP - PL_stack_base;
13689cfe 2159 volatile I32 retval = 0;
4633a7c4 2160 I32 oldscope;
6224f72b 2161 int ret;
533c011a 2162 OP* oldop = PL_op;
db36c5a1 2163 dJMPENV;
84902520 2164
4633a7c4
LW		 2165 if (flags & G_DISCARD) {
2166 ENTER;
2167 SAVETMPS;
2168 }
2169
462e5cf6 2170 SAVEOP();
533c011a
NIS		 2171 PL_op = (OP*)&myop;
2172 Zero(PL_op, 1, UNOP);
3280af22
NIS		 2173 EXTEND(PL_stack_sp, 1);
2174 *++PL_stack_sp = sv;
2175 oldscope = PL_scopestack_ix;
79072805 2176
4633a7c4
LW		 2177 if (!(flags & G_NOARGS))
2178 myop.op_flags = OPf_STACKED;
79072805 2179 myop.op_next = Nullop;
6e72f9df 2180 myop.op_type = OP_ENTEREVAL;
54310121 2181 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
2182 (flags & G_ARRAY) ? OPf_WANT_LIST :
2183 OPf_WANT_SCALAR);
6e72f9df 2184 if (flags & G_KEEPERR)
2185 myop.op_flags |= OPf_SPECIAL;
4633a7c4 2186
dedbcade
DM		 2187 /* fail now; otherwise we could fail after the JMPENV_PUSH but
2188 * before a PUSHEVAL, which corrupts the stack after a croak */
2189 TAINT_PROPER("eval_sv()");
2190
14dd3ad8 2191 JMPENV_PUSH(ret);
6224f72b
GS		 2192 switch (ret) {
2193 case 0:
14dd3ad8
GS		 2194 redo_body:
2195 call_body((OP*)&myop,TRUE);
312caa8e
CS		 2196 retval = PL_stack_sp - (PL_stack_base + oldmark);
2197 if (!(flags & G_KEEPERR))
2198 sv_setpv(ERRSV,"");
4633a7c4 2199 break;
6224f72b 2200 case 1:
f86702cc 2201 STATUS_ALL_FAILURE;
4633a7c4 2202 /* FALL THROUGH */
6224f72b 2203 case 2:
4633a7c4 2204 /* my_exit() was called */
3280af22 2205 PL_curstash = PL_defstash;
4633a7c4 2206 FREETMPS;
14dd3ad8 2207 JMPENV_POP;
cc3604b1 2208 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
cea2e8a9 2209 Perl_croak(aTHX_ "Callback called exit");
f86702cc 2210 my_exit_jump();
4633a7c4 2211 /* NOTREACHED */
6224f72b 2212 case 3:
3280af22 2213 if (PL_restartop) {
533c011a 2214 PL_op = PL_restartop;
3280af22 2215 PL_restartop = 0;
312caa8e 2216 goto redo_body;
4633a7c4 2217 }
3280af22 2218 PL_stack_sp = PL_stack_base + oldmark;
4633a7c4
LW		 2219 if (flags & G_ARRAY)
2220 retval = 0;
2221 else {
2222 retval = 1;
3280af22 2223 *++PL_stack_sp = &PL_sv_undef;
4633a7c4 2224 }
312caa8e 2225 break;
4633a7c4
LW		 2226 }
2227
14dd3ad8 2228 JMPENV_POP;
4633a7c4 2229 if (flags & G_DISCARD) {
3280af22 2230 PL_stack_sp = PL_stack_base + oldmark;
4633a7c4
LW		 2231 retval = 0;
2232 FREETMPS;
2233 LEAVE;
2234 }
533c011a 2235 PL_op = oldop;
4633a7c4
LW		 2236 return retval;
2237}
2238
954c1994
GS		 2239/*
2240=for apidoc p||eval_pv
2241
2242Tells Perl to C<eval> the given string and return an SV* result.
2243
2244=cut
2245*/
2246
137443ea 2247SV*
864dbfa3 2248Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
137443ea 2249{
2250 dSP;
2251 SV* sv = newSVpv(p, 0);
2252
864dbfa3 2253 eval_sv(sv, G_SCALAR);
137443ea 2254 SvREFCNT_dec(sv);
2255
2256 SPAGAIN;
2257 sv = POPs;
2258 PUTBACK;
2259
2d8e6c8d
GS		 2260 if (croak_on_error && SvTRUE(ERRSV)) {
2261 STRLEN n_a;
cea2e8a9 2262 Perl_croak(aTHX_ SvPVx(ERRSV, n_a));
2d8e6c8d 2263 }
137443ea 2264
2265 return sv;
2266}
2267
4633a7c4
LW		 2268/* Require a module. */
2269
954c1994 2270/*
ccfc67b7
JH		 2271=head1 Embedding Functions
2272
954c1994
GS		 2273=for apidoc p||require_pv
2274
7d3fb230
BS		 2275Tells Perl to C<require> the file named by the string argument. It is
2276analogous to the Perl code C<eval "require '$file'">. It's even
2307c6d0 2277implemented that way; consider using load_module instead.
954c1994 2278
7d3fb230 2279=cut */
954c1994 2280
4633a7c4 2281void
864dbfa3 2282Perl_require_pv(pTHX_ const char *pv)
4633a7c4 2283{
d3acc0f7
JP		 2284 SV* sv;
2285 dSP;
e788e7d3 2286 PUSHSTACKi(PERLSI_REQUIRE);
d3acc0f7
JP		 2287 PUTBACK;
2288 sv = sv_newmortal();
4633a7c4
LW		 2289 sv_setpv(sv, "require '");
2290 sv_catpv(sv, pv);
2291 sv_catpv(sv, "'");
864dbfa3 2292 eval_sv(sv, G_DISCARD);
d3acc0f7
JP		 2293 SPAGAIN;
2294 POPSTACK;
79072805
LW		 2295}
2296
79072805 2297void
864dbfa3 2298Perl_magicname(pTHX_ char *sym, char *name, I32 namlen)
79072805
LW		 2299{
2300 register GV *gv;
2301
155aba94 2302 if ((gv = gv_fetchpv(sym,TRUE, SVt_PV)))
14befaf4 2303 sv_magic(GvSV(gv), (SV*)gv, PERL_MAGIC_sv, name, namlen);
79072805
LW		 2304}
2305
76e3520e 2306STATIC void
cea2e8a9 2307S_usage(pTHX_ char *name) /* XXX move this out into a module ? */
4633a7c4 2308{
ab821d7f 2309 /* This message really ought to be max 23 lines.
75c72d73 2310 * Removed -h because the user already knows that option. Others? */
fb73857a 2311
76e3520e 2312 static char *usage_msg[] = {
fb73857a 2313"-0[octal] specify record separator (\\0, if no argument)",
2314"-a autosplit mode with -n or -p (splits $_ into @F)",
fb3560ee 2315"-C[number/list] enables the listed Unicode features",
1950ee41 2316"-c check syntax only (runs BEGIN and CHECK blocks)",
aac3bd0d
GS		 2317"-d[:debugger] run program under debugger",
2318"-D[number/list] set debugging flags (argument is a bit mask or alphabets)",
90490ea3 2319"-e program one line of program (several -e's allowed, omit programfile)",
aac3bd0d
GS		 2320"-F/pattern/ split() pattern for -a switch (//'s are optional)",
2321"-i[extension] edit <> files in place (makes backup if extension supplied)",
2322"-Idirectory specify @INC/#include directory (several -I's allowed)",
fb73857a 2323"-l[octal] enable line ending processing, specifies line terminator",
aac3bd0d
GS		 2324"-[mM][-]module execute `use/no module...' before executing program",
2325"-n assume 'while (<>) { ... }' loop around program",
2326"-p assume loop like -n but print line also, like sed",
2327"-P run program through C preprocessor before compilation",
2328"-s enable rudimentary parsing for switches after programfile",
2329"-S look for programfile using PATH environment variable",
9cbc33e8 2330"-t enable tainting warnings",
90490ea3 2331"-T enable tainting checks",
aac3bd0d 2332"-u dump core after parsing program",
fb73857a 2333"-U allow unsafe operations",
aac3bd0d
GS		 2334"-v print version, subversion (includes VERY IMPORTANT perl info)",
2335"-V[:variable] print configuration summary (or a single Config.pm variable)",
2336"-w enable many useful warnings (RECOMMENDED)",
3c0facb2 2337"-W enable all warnings",
fb73857a 2338"-x[directory] strip off text before #!perl line and perhaps cd to directory",
90490ea3 2339"-X disable all warnings",
fb73857a 2340"\n",
2341NULL
2342};
76e3520e 2343 char **p = usage_msg;
fb73857a 2344
b0e47665
GS		 2345 PerlIO_printf(PerlIO_stdout(),
2346 "\nUsage: %s [switches] [--] [programfile] [arguments]",
2347 name);
fb73857a 2348 while (*p)
b0e47665 2349 PerlIO_printf(PerlIO_stdout(), "\n %s", *p++);
4633a7c4
LW		 2350}
2351
b4ab917c
DM		 2352/* convert a string of -D options (or digits) into an int.
2353 * sets *s to point to the char after the options */
2354
2355#ifdef DEBUGGING
2356int
ddcf8bc1 2357Perl_get_debug_opts(pTHX_ char **s, bool givehelp)
b4ab917c 2358{
e6e64d9b
JC		 2359 static char *usage_msgd[] = {
2360 " Debugging flag values: (see also -d)",
2361 " p Tokenizing and parsing (with v, displays parse stack)",
3679267a 2362 " s Stack snapshots (with v, displays all stacks)",
e6e64d9b
JC		 2363 " l Context (loop) stack processing",
2364 " t Trace execution",
2365 " o Method and overloading resolution",
2366 " c String/numeric conversions",
2367 " P Print profiling info, preprocessor command for -P, source file input state",
2368 " m Memory allocation",
2369 " f Format processing",
2370 " r Regular expression parsing and execution",
2371 " x Syntax tree dump",
3679267a 2372 " u Tainting checks",
e6e64d9b
JC		 2373 " H Hash dump -- usurps values()",
2374 " X Scratchpad allocation",
2375 " D Cleaning up",
2376 " S Thread synchronization",
2377 " T Tokenising",
2378 " R Include reference counts of dumped variables (eg when using -Ds)",
2379 " J Do not s,t,P-debug (Jump over) opcodes within package DB",
2380 " v Verbose: use in conjunction with other flags",
2381 " C Copy On Write",
2382 " A Consistency checks on internal structures",
3679267a 2383 " q quiet - currently only suppresses the 'EXECUTING' message",
e6e64d9b
JC		 2384 NULL
2385 };
b4ab917c
DM		 2386 int i = 0;
2387 if (isALPHA(**s)) {
2388 /* if adding extra options, remember to update DEBUG_MASK */
ecae49c0 2389 static char debopts[] = "psltocPmfrxu HXDSTRJvCAq";
b4ab917c
DM		 2390
2391 for (; isALNUM(**s); (*s)++) {
2392 char *d = strchr(debopts,**s);
2393 if (d)
2394 i |= 1 << (d - debopts);
2395 else if (ckWARN_d(WARN_DEBUGGING))
e6e64d9b
JC		 2396 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
2397 "invalid option -D%c, use -D'' to see choices\n", **s);
b4ab917c
DM		 2398 }
2399 }
e6e64d9b 2400 else if (isDIGIT(**s)) {
b4ab917c
DM		 2401 i = atoi(*s);
2402 for (; isALNUM(**s); (*s)++) ;
2403 }
ddcf8bc1 2404 else if (givehelp) {
e6e64d9b
JC		 2405 char **p = usage_msgd;
2406 while (*p) PerlIO_printf(PerlIO_stdout(), "%s\n", *p++);
2407 }
b4ab917c
DM		 2408# ifdef EBCDIC
2409 if ((i & DEBUG_p_FLAG) && ckWARN_d(WARN_DEBUGGING))
2410 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
2411 "-Dp not implemented on this platform\n");
2412# endif
2413 return i;
2414}
2415#endif
2416
79072805
LW		 2417/* This routine handles any switches that can be given during run */
2418
2419char *
864dbfa3 2420Perl_moreswitches(pTHX_ char *s)
79072805 2421{
ba210ebe 2422 STRLEN numlen;
84c133a0 2423 UV rschar;
79072805
LW		 2424
2425 switch (*s) {
2426 case '0':
a863c7d1 2427 {
f2095865
JH		 2428 I32 flags = 0;
2429
2430 SvREFCNT_dec(PL_rs);
2431 if (s[1] == 'x' && s[2]) {
2432 char *e;
2433 U8 *tmps;
2434
2435 for (s += 2, e = s; *e; e++);
2436 numlen = e - s;
2437 flags = PERL_SCAN_SILENT_ILLDIGIT;
2438 rschar = (U32)grok_hex(s, &numlen, &flags, NULL);
2439 if (s + numlen < e) {
2440 rschar = 0; /* Grandfather -0xFOO as -0 -xFOO. */
2441 numlen = 0;
2442 s--;
2443 }
2444 PL_rs = newSVpvn("", 0);
c5661c80 2445 SvGROW(PL_rs, (STRLEN)(UNISKIP(rschar) + 1));
f2095865
JH		 2446 tmps = (U8*)SvPVX(PL_rs);
2447 uvchr_to_utf8(tmps, rschar);
2448 SvCUR_set(PL_rs, UNISKIP(rschar));
2449 SvUTF8_on(PL_rs);
2450 }
2451 else {
2452 numlen = 4;
2453 rschar = (U32)grok_oct(s, &numlen, &flags, NULL);
2454 if (rschar & ~((U8)~0))
2455 PL_rs = &PL_sv_undef;
2456 else if (!rschar && numlen >= 2)
2457 PL_rs = newSVpvn("", 0);
2458 else {
2459 char ch = (char)rschar;
2460 PL_rs = newSVpvn(&ch, 1);
2461 }
2462 }
800633c3 2463 sv_setsv(get_sv("/", TRUE), PL_rs);
f2095865 2464 return s + numlen;
a863c7d1 2465 }
46487f74 2466 case 'C':
a05d7ebb
JH		 2467 s++;
2468 PL_unicode = parse_unicode_opts(&s);
46487f74 2469 return s;
2304df62 2470 case 'F':
3280af22 2471 PL_minus_F = TRUE;
ebce5377
RGS		 2472 PL_splitstr = ++s;
2473 while (*s && !isSPACE(*s)) ++s;
2474 *s = '\0';
2475 PL_splitstr = savepv(PL_splitstr);
2304df62 2476 return s;
79072805 2477 case 'a':
3280af22 2478 PL_minus_a = TRUE;
79072805
LW		 2479 s++;
2480 return s;
2481 case 'c':
3280af22 2482 PL_minus_c = TRUE;
79072805
LW		 2483 s++;
2484 return s;
2485 case 'd':
bbce6d69 2486 forbid_setid("-d");
4633a7c4 2487 s++;
2cbb2ee1
RGS		 2488
2489 /* -dt indicates to the debugger that threads will be used */
2490 if (*s == 't' && !isALNUM(s[1])) {
2491 ++s;
2492 my_setenv("PERL5DB_THREADED", "1");
2493 }
2494
70c94a19
RR		 2495 /* The following permits -d:Mod to accepts arguments following an =
2496 in the fashion that -MSome::Mod does. */
2497 if (*s == ':' || *s == '=') {
2498 char *start;
2499 SV *sv;
2500 sv = newSVpv("use Devel::", 0);
2501 start = ++s;
2502 /* We now allow -d:Module=Foo,Bar */
2503 while(isALNUM(*s) || *s==':') ++s;
2504 if (*s != '=')
2505 sv_catpv(sv, start);
2506 else {
2507 sv_catpvn(sv, start, s-start);
2508 sv_catpv(sv, " split(/,/,q{");
2509 sv_catpv(sv, ++s);
3d27e215 2510 sv_catpv(sv, "})");
70c94a19 2511 }
4633a7c4 2512 s += strlen(s);
70c94a19 2513 my_setenv("PERL5DB", SvPV(sv, PL_na));
4633a7c4 2514 }
ed094faf 2515 if (!PL_perldb) {
3280af22 2516 PL_perldb = PERLDB_ALL;
a0d0e21e 2517 init_debugger();
ed094faf 2518 }
79072805
LW		 2519 return s;
2520 case 'D':
0453d815 2521 {
79072805 2522#ifdef DEBUGGING
bbce6d69 2523 forbid_setid("-D");
b4ab917c 2524 s++;
ddcf8bc1 2525 PL_debug = get_debug_opts(&s, 1) | DEBUG_TOP_FLAG;
12a43e32 2526#else /* !DEBUGGING */
0453d815 2527 if (ckWARN_d(WARN_DEBUGGING))
9014280d 2528 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
e6e64d9b 2529 "Recompile perl with -DDEBUGGING to use -D switch (did you mean -d ?)\n");
a0d0e21e 2530 for (s++; isALNUM(*s); s++) ;
79072805
LW		 2531#endif
2532 /*SUPPRESS 530*/
2533 return s;
0453d815 2534 }
4633a7c4 2535 case 'h':
ac27b0f5 2536 usage(PL_origargv[0]);
7ca617d0 2537 my_exit(0);
79072805 2538 case 'i':
3280af22
NIS		 2539 if (PL_inplace)
2540 Safefree(PL_inplace);
c030f24b
GH		 2541#if defined(__CYGWIN__) /* do backup extension automagically */
2542 if (*(s+1) == '\0') {
2543 PL_inplace = savepv(".bak");
2544 return s+1;
2545 }
2546#endif /* __CYGWIN__ */
3280af22 2547 PL_inplace = savepv(s+1);
79072805 2548 /*SUPPRESS 530*/
3280af22 2549 for (s = PL_inplace; *s && !isSPACE(*s); s++) ;
7b8d334a 2550 if (*s) {
fb73857a 2551 *s++ = '\0';
7b8d334a
GS		 2552 if (*s == '-') /* Additional switches on #! line. */
2553 s++;
2554 }
fb73857a 2555 return s;
4e49a025 2556 case 'I': /* -I handled both here and in parse_body() */
bbce6d69 2557 forbid_setid("-I");
fb73857a 2558 ++s;
2559 while (*s && isSPACE(*s))
2560 ++s;
2561 if (*s) {
774d564b 2562 char *e, *p;
0df16ed7
GS		 2563 p = s;
2564 /* ignore trailing spaces (possibly followed by other switches) */
2565 do {
2566 for (e = p; *e && !isSPACE(*e); e++) ;
2567 p = e;
2568 while (isSPACE(*p))
2569 p++;
2570 } while (*p && *p != '-');
2571 e = savepvn(s, e-s);
88fe16b2 2572 incpush(e, TRUE, TRUE, FALSE, FALSE);
0df16ed7
GS		 2573 Safefree(e);
2574 s = p;
2575 if (*s == '-')
2576 s++;
79072805
LW		 2577 }
2578 else
a67e862a 2579 Perl_croak(aTHX_ "No directory specified for -I");
fb73857a 2580 return s;
79072805 2581 case 'l':
3280af22 2582 PL_minus_l = TRUE;
79072805 2583 s++;
7889fe52
NIS		 2584 if (PL_ors_sv) {
2585 SvREFCNT_dec(PL_ors_sv);
2586 PL_ors_sv = Nullsv;
2587 }
79072805 2588 if (isDIGIT(*s)) {
53305cf1 2589 I32 flags = 0;
7889fe52 2590 PL_ors_sv = newSVpvn("\n",1);
53305cf1
NC		 2591 numlen = 3 + (*s == '0');
2592 *SvPVX(PL_ors_sv) = (char)grok_oct(s, &numlen, &flags, NULL);
79072805
LW		 2593 s += numlen;
2594 }
2595 else {
8bfdd7d9 2596 if (RsPARA(PL_rs)) {
7889fe52
NIS		 2597 PL_ors_sv = newSVpvn("\n\n",2);
2598 }
2599 else {
8bfdd7d9 2600 PL_ors_sv = newSVsv(PL_rs);
c07a80fd 2601 }
79072805
LW		 2602 }
2603 return s;
06492da6
SF		 2604 case 'A':
2605 forbid_setid("-A");
930366bd
RGS		 2606 if (!PL_preambleav)
2607 PL_preambleav = newAV();
06492da6 2608 if (*++s) {
3d27e215
LM		 2609 SV *sv = newSVpv("use assertions::activate split(/,/,q", 0);
2610 sv_catpvn(sv, "\0", 1); /* Use NUL as q//-delimiter. */
06492da6 2611 sv_catpv(sv,s);
3d27e215 2612 sv_catpvn(sv, "\0)", 2);
06492da6 2613 s+=strlen(s);
06492da6
SF		 2614 av_push(PL_preambleav, sv);
2615 }
2616 else
930366bd 2617 av_push(PL_preambleav, newSVpvn("use assertions::activate",24));
06492da6 2618 return s;
1a30305b 2619 case 'M':
bbce6d69 2620 forbid_setid("-M"); /* XXX ? */
1a30305b 2621 /* FALL THROUGH */
2622 case 'm':
bbce6d69 2623 forbid_setid("-m"); /* XXX ? */
1a30305b 2624 if (*++s) {
a5f75d66 2625 char *start;
11343788 2626 SV *sv;
a5f75d66
AD		 2627 char *use = "use ";
2628 /* -M-foo == 'no foo' */
2629 if (*s == '-') { use = "no "; ++s; }
11343788 2630 sv = newSVpv(use,0);
a5f75d66 2631 start = s;
1a30305b 2632 /* We allow -M'Module qw(Foo Bar)' */
c07a80fd 2633 while(isALNUM(*s) || *s==':') ++s;
2634 if (*s != '=') {
11343788 2635 sv_catpv(sv, start);
c07a80fd 2636 if (*(start-1) == 'm') {
2637 if (*s != '\0')
cea2e8a9 2638 Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
11343788 2639 sv_catpv( sv, " ()");
c07a80fd 2640 }
2641 } else {
6df41af2 2642 if (s == start)
be98fb35
GS		 2643 Perl_croak(aTHX_ "Module name required with -%c option",
2644 s[-1]);
11343788 2645 sv_catpvn(sv, start, s-start);
3d27e215
LM		 2646 sv_catpv(sv, " split(/,/,q");
2647 sv_catpvn(sv, "\0)", 1); /* Use NUL as q//-delimiter. */
11343788 2648 sv_catpv(sv, ++s);
3d27e215 2649 sv_catpvn(sv, "\0)", 2);
c07a80fd 2650 }
1a30305b 2651 s += strlen(s);
5c831c24 2652 if (!PL_preambleav)
3280af22
NIS		 2653 PL_preambleav = newAV();
2654 av_push(PL_preambleav, sv);
1a30305b 2655 }
2656 else
9e81e6a1 2657 Perl_croak(aTHX_ "Missing argument to -%c", *(s-1));
1a30305b 2658 return s;
79072805 2659 case 'n':
3280af22 2660 PL_minus_n = TRUE;
79072805
LW		 2661 s++;
2662 return s;
2663 case 'p':
3280af22 2664 PL_minus_p = TRUE;
79072805
LW		 2665 s++;
2666 return s;
2667 case 's':
bbce6d69 2668 forbid_setid("-s");
3280af22 2669 PL_doswitches = TRUE;
79072805
LW		 2670 s++;
2671 return s;
6537fe72
MS		 2672 case 't':
2673 if (!PL_tainting)
22f7c9c9 2674 TOO_LATE_FOR('t');
6537fe72
MS		 2675 s++;
2676 return s;
463ee0b2 2677 case 'T':
3280af22 2678 if (!PL_tainting)
22f7c9c9 2679 TOO_LATE_FOR('T');
463ee0b2
LW		 2680 s++;
2681 return s;
79072805 2682 case 'u':
bf4acbe4
GS		 2683#ifdef MACOS_TRADITIONAL
2684 Perl_croak(aTHX_ "Believe me, you don't want to use \"-u\" on a Macintosh");
2685#endif
3280af22 2686 PL_do_undump = TRUE;
79072805
LW		 2687 s++;
2688 return s;
2689 case 'U':
3280af22 2690 PL_unsafe = TRUE;
79072805
LW		 2691 s++;
2692 return s;
2693 case 'v':
d7aa5382
JP		 2694 if (!sv_derived_from(PL_patchlevel, "version"))
2695 (void *)upg_version(PL_patchlevel);
8e9464f1 2696#if !defined(DGUX)
b0e47665 2697 PerlIO_printf(PerlIO_stdout(),
014ead4b 2698 Perl_form(aTHX_ "\nThis is perl, v%"SVf" built for %s",
d7aa5382
JP		 2699 vstringify(PL_patchlevel),
2700 ARCHNAME));
8e9464f1
JH		 2701#else /* DGUX */
2702/* Adjust verbose output as in the perl that ships with the DG/UX OS from EMC */
2703 PerlIO_printf(PerlIO_stdout(),
014ead4b 2704 Perl_form(aTHX_ "\nThis is perl, v%"SVf"\n",
d7aa5382 2705 vstringify(PL_patchlevel)));
8e9464f1
JH		 2706 PerlIO_printf(PerlIO_stdout(),
2707 Perl_form(aTHX_ " built under %s at %s %s\n",
2708 OSNAME, __DATE__, __TIME__));
2709 PerlIO_printf(PerlIO_stdout(),
2710 Perl_form(aTHX_ " OS Specific Release: %s\n",
40a39f85 2711 OSVERS));
8e9464f1
JH		 2712#endif /* !DGUX */
2713
fb73857a 2714#if defined(LOCAL_PATCH_COUNT)
2715 if (LOCAL_PATCH_COUNT > 0)
b0e47665
GS		 2716 PerlIO_printf(PerlIO_stdout(),
2717 "\n(with %d registered patch%s, "
2718 "see perl -V for more detail)",
2719 (int)LOCAL_PATCH_COUNT,
2720 (LOCAL_PATCH_COUNT!=1) ? "es" : "");
a5f75d66 2721#endif
1a30305b 2722
b0e47665 2723 PerlIO_printf(PerlIO_stdout(),
45a2796c 2724 "\n\nCopyright 1987-2004, Larry Wall\n");
eae9c151
JH		 2725#ifdef MACOS_TRADITIONAL
2726 PerlIO_printf(PerlIO_stdout(),
be3c0a43 2727 "\nMac OS port Copyright 1991-2002, Matthias Neeracher;\n"
03765510 2728 "maintained by Chris Nandor\n");
eae9c151 2729#endif
79072805 2730#ifdef MSDOS
b0e47665
GS		 2731 PerlIO_printf(PerlIO_stdout(),
2732 "\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
55497cff 2733#endif
2734#ifdef DJGPP
b0e47665
GS		 2735 PerlIO_printf(PerlIO_stdout(),
2736 "djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n"
2737 "djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
4633a7c4 2738#endif
79072805 2739#ifdef OS2
b0e47665
GS		 2740 PerlIO_printf(PerlIO_stdout(),
2741 "\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
be3c0a43 2742 "Version 5 port Copyright (c) 1994-2002, Andreas Kaiser, Ilya Zakharevich\n");
79072805 2743#endif
79072805 2744#ifdef atarist
b0e47665
GS		 2745 PerlIO_printf(PerlIO_stdout(),
2746 "atariST series port, ++jrb bammi@cadence.com\n");
79072805 2747#endif
a3f9223b 2748#ifdef __BEOS__
b0e47665
GS		 2749 PerlIO_printf(PerlIO_stdout(),
2750 "BeOS port Copyright Tom Spindler, 1997-1999\n");
a3f9223b 2751#endif
1d84e8df 2752#ifdef MPE
b0e47665 2753 PerlIO_printf(PerlIO_stdout(),
e583a879 2754 "MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-2003\n");
1d84e8df 2755#endif
9d116dd7 2756#ifdef OEMVS
b0e47665
GS		 2757 PerlIO_printf(PerlIO_stdout(),
2758 "MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
9d116dd7 2759#endif
495c5fdc 2760#ifdef __VOS__
b0e47665 2761 PerlIO_printf(PerlIO_stdout(),
94efb9fb 2762 "Stratus VOS port by Paul.Green@stratus.com, 1997-2002\n");
495c5fdc 2763#endif
092bebab 2764#ifdef __OPEN_VM
b0e47665
GS		 2765 PerlIO_printf(PerlIO_stdout(),
2766 "VM/ESA port by Neale Ferguson, 1998-1999\n");
092bebab 2767#endif
a1a0e61e 2768#ifdef POSIX_BC
b0e47665
GS		 2769 PerlIO_printf(PerlIO_stdout(),
2770 "BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
a1a0e61e 2771#endif
61ae2fbf 2772#ifdef __MINT__
b0e47665
GS		 2773 PerlIO_printf(PerlIO_stdout(),
2774 "MiNT port by Guido Flohr, 1997-1999\n");
61ae2fbf 2775#endif
f83d2536 2776#ifdef EPOC
b0e47665 2777 PerlIO_printf(PerlIO_stdout(),
be3c0a43 2778 "EPOC port by Olaf Flebbe, 1999-2002\n");
f83d2536 2779#endif
e1caacb4 2780#ifdef UNDER_CE
b475b3e6
JH		 2781 PerlIO_printf(PerlIO_stdout(),"WINCE port by Rainer Keuchel, 2001-2002\n");
2782 PerlIO_printf(PerlIO_stdout(),"Built on " __DATE__ " " __TIME__ "\n\n");
e1caacb4
JH		 2783 wce_hitreturn();
2784#endif
baed7233
DL		 2785#ifdef BINARY_BUILD_NOTICE
2786 BINARY_BUILD_NOTICE;
2787#endif
b0e47665
GS		 2788 PerlIO_printf(PerlIO_stdout(),
2789 "\n\
79072805 2790Perl may be copied only under the terms of either the Artistic License or the\n\
3d6f292d 2791GNU General Public License, which may be found in the Perl 5 source kit.\n\n\
95103687
GS		 2792Complete documentation for Perl, including FAQ lists, should be found on\n\
2793this system using `man perl' or `perldoc perl'. If you have access to the\n\
c9e30dd8 2794Internet, point your browser at http://www.perl.org/, the Perl Home Page.\n\n");
7ca617d0 2795 my_exit(0);
79072805 2796 case 'w':
599cee73 2797 if (! (PL_dowarn & G_WARN_ALL_MASK))
ac27b0f5 2798 PL_dowarn |= G_WARN_ON;
599cee73
PM		 2799 s++;
2800 return s;
2801 case 'W':
ac27b0f5 2802 PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
317ea90d
MS		 2803 if (!specialWARN(PL_compiling.cop_warnings))
2804 SvREFCNT_dec(PL_compiling.cop_warnings);
d3a7d8c7 2805 PL_compiling.cop_warnings = pWARN_ALL ;
599cee73
PM		 2806 s++;
2807 return s;
2808 case 'X':
ac27b0f5 2809 PL_dowarn = G_WARN_ALL_OFF;
317ea90d
MS		 2810 if (!specialWARN(PL_compiling.cop_warnings))
2811 SvREFCNT_dec(PL_compiling.cop_warnings);
d3a7d8c7 2812 PL_compiling.cop_warnings = pWARN_NONE ;
79072805
LW		 2813 s++;
2814 return s;
a0d0e21e 2815 case '*':
79072805
LW		 2816 case ' ':
2817 if (s[1] == '-') /* Additional switches on #! line. */
2818 return s+2;
2819 break;
a0d0e21e 2820 case '-':
79072805 2821 case 0:
51882d45 2822#if defined(WIN32) || !defined(PERL_STRICT_CR)
a868473f
NIS		 2823 case '\r':
2824#endif
79072805
LW		 2825 case '\n':
2826 case '\t':
2827 break;
aa689395 2828#ifdef ALTERNATE_SHEBANG
2829 case 'S': /* OS/2 needs -S on "extproc" line. */
2830 break;
2831#endif
a0d0e21e 2832 case 'P':
3280af22 2833 if (PL_preprocess)
a0d0e21e
LW		 2834 return s+1;
2835 /* FALL THROUGH */
79072805 2836 default:
cea2e8a9 2837 Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
79072805
LW		 2838 }
2839 return Nullch;
2840}
2841
2842/* compliments of Tom Christiansen */
2843
2844/* unexec() can be found in the Gnu emacs distribution */
ee580363 2845/* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
79072805
LW		 2846
2847void
864dbfa3 2848Perl_my_unexec(pTHX)
79072805
LW		 2849{
2850#ifdef UNEXEC
46fc3d4c 2851 SV* prog;
2852 SV* file;
ee580363 2853 int status = 1;
79072805
LW		 2854 extern int etext;
2855
ee580363 2856 prog = newSVpv(BIN_EXP, 0);
46fc3d4c 2857 sv_catpv(prog, "/perl");
6b88bc9c 2858 file = newSVpv(PL_origfilename, 0);
46fc3d4c 2859 sv_catpv(file, ".perldump");
79072805 2860
ee580363
GS		 2861 unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
2862 /* unexec prints msg to stderr in case of failure */
6ad3d225 2863 PerlProc_exit(status);
79072805 2864#else
a5f75d66
AD		 2865# ifdef VMS
2866# include <lib$routines.h>
2867 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
aa689395 2868# else
79072805 2869 ABORT(); /* for use with undump */
aa689395 2870# endif
a5f75d66 2871#endif
79072805
LW		 2872}
2873
cb68f92d
GS		 2874/* initialize curinterp */
2875STATIC void
cea2e8a9 2876S_init_interp(pTHX)
cb68f92d
GS		 2877{
2878
acfe0abc
GS		 2879#ifdef MULTIPLICITY
2880# define PERLVAR(var,type)
2881# define PERLVARA(var,n,type)
2882# if defined(PERL_IMPLICIT_CONTEXT)
2883# if defined(USE_5005THREADS)
2884# define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
c5be433b 2885# define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
acfe0abc
GS		 2886# else /* !USE_5005THREADS */
2887# define PERLVARI(var,type,init) aTHX->var = init;
2888# define PERLVARIC(var,type,init) aTHX->var = init;
2889# endif /* USE_5005THREADS */
3967c732 2890# else
acfe0abc
GS		 2891# define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
2892# define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
066ef5b5 2893# endif
acfe0abc
GS		 2894# include "intrpvar.h"
2895# ifndef USE_5005THREADS
2896# include "thrdvar.h"
2897# endif
2898# undef PERLVAR
2899# undef PERLVARA
2900# undef PERLVARI
2901# undef PERLVARIC
2902#else
2903# define PERLVAR(var,type)
2904# define PERLVARA(var,n,type)
2905# define PERLVARI(var,type,init) PL_##var = init;
2906# define PERLVARIC(var,type,init) PL_##var = init;
2907# include "intrpvar.h"
2908# ifndef USE_5005THREADS
2909# include "thrdvar.h"
2910# endif
2911# undef PERLVAR
2912# undef PERLVARA
2913# undef PERLVARI
2914# undef PERLVARIC
cb68f92d
GS		 2915#endif
2916
cb68f92d
GS		 2917}
2918
76e3520e 2919STATIC void
cea2e8a9 2920S_init_main_stash(pTHX)
79072805 2921{
463ee0b2 2922 GV *gv;
6e72f9df 2923
3280af22 2924 PL_curstash = PL_defstash = newHV();
79cb57f6 2925 PL_curstname = newSVpvn("main",4);
adbc6bb1
LW		 2926 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
2927 SvREFCNT_dec(GvHV(gv));
3280af22 2928 GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);
463ee0b2 2929 SvREADONLY_on(gv);
ff5bdd37 2930 HvNAME(PL_defstash) = savepvn("main", 4);
3280af22
NIS		 2931 PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
2932 GvMULTI_on(PL_incgv);
2933 PL_hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */
2934 GvMULTI_on(PL_hintgv);
2935 PL_defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
2936 PL_errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
2937 GvMULTI_on(PL_errgv);
2938 PL_replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */
2939 GvMULTI_on(PL_replgv);
cea2e8a9 2940 (void)Perl_form(aTHX_ "%240s",""); /* Preallocate temp - for immediate signals. */
38a03e6e
MB		 2941 sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
2942 sv_setpvn(ERRSV, "", 0);
3280af22 2943 PL_curstash = PL_defstash;
11faa288 2944 CopSTASH_set(&PL_compiling, PL_defstash);
ed094faf 2945 PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
3280af22 2946 PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
4633a7c4 2947 /* We must init $/ before switches are processed. */
864dbfa3 2948 sv_setpvn(get_sv("/", TRUE), "\n", 1);
79072805
LW		 2949}
2950
ae3f3efd 2951/* PSz 18 Nov 03 fdscript now global but do not change prototype */
76e3520e 2952STATIC void
c5cccb17 2953S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv)
79072805 2954{
ae3f3efd 2955#ifndef IAMSUID
1b24ed4b
MS		 2956 char *quote;
2957 char *code;
2958 char *cpp_discard_flag;
2959 char *perl;
ae3f3efd 2960#endif
1b24ed4b 2961
ae3f3efd
PS		 2962 PL_fdscript = -1;
2963 PL_suidscript = -1;
79072805 2964
3280af22 2965 if (PL_e_script) {
ff5bdd37 2966 PL_origfilename = savepvn("-e", 2);
96436eeb 2967 }
6c4ab083
GS		 2968 else {
2969 /* if find_script() returns, it returns a malloc()-ed value */
3280af22 2970 PL_origfilename = scriptname = find_script(scriptname, dosearch, NULL, 1);
6c4ab083
GS		 2971
2972 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
2973 char *s = scriptname + 8;
ae3f3efd 2974 PL_fdscript = atoi(s);
6c4ab083
GS		 2975 while (isDIGIT(*s))
2976 s++;
2977 if (*s) {
ae3f3efd
PS		 2978 /* PSz 18 Feb 04
2979 * Tell apart "normal" usage of fdscript, e.g.
2980 * with bash on FreeBSD:
2981 * perl <( echo '#!perl -DA'; echo 'print "$0\n"')
2982 * from usage in suidperl.
2983 * Does any "normal" usage leave garbage after the number???
2984 * Is it a mistake to use a similar /dev/fd/ construct for
2985 * suidperl?
2986 */
2987 PL_suidscript = 1;
2988 /* PSz 20 Feb 04
2989 * Be supersafe and do some sanity-checks.
2990 * Still, can we be sure we got the right thing?
2991 */
2992 if (*s != '/') {
2993 Perl_croak(aTHX_ "Wrong syntax (suid) fd script name \"%s\"\n", s);
2994 }
2995 if (! *(s+1)) {
2996 Perl_croak(aTHX_ "Missing (suid) fd script name\n");
2997 }
6c4ab083 2998 scriptname = savepv(s + 1);
3280af22
NIS		 2999 Safefree(PL_origfilename);
3000 PL_origfilename = scriptname;
6c4ab083
GS		 3001 }
3002 }
3003 }
3004
05ec9bb3 3005 CopFILE_free(PL_curcop);
57843af0 3006 CopFILE_set(PL_curcop, PL_origfilename);
770526c1 3007 if (*PL_origfilename == '-' && PL_origfilename[1] == '\0')
79072805 3008 scriptname = "";
ae3f3efd
PS		 3009 if (PL_fdscript >= 0) {
3010 PL_rsfp = PerlIO_fdopen(PL_fdscript,PERL_SCRIPT_MODE);
1b24ed4b
MS		 3011# if defined(HAS_FCNTL) && defined(F_SETFD)
3012 if (PL_rsfp)
3013 /* ensure close-on-exec */
3014 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);
3015# endif
96436eeb 3016 }
ae3f3efd
PS		 3017#ifdef IAMSUID
3018 else {
86207487
NC		 3019 Perl_croak(aTHX_ "sperl needs fd script\n"
3020 "You should not call sperl directly; do you need to "
3021 "change a #! line\nfrom sperl to perl?\n");
3022
ae3f3efd
PS		 3023/* PSz 11 Nov 03
3024 * Do not open (or do other fancy stuff) while setuid.
3025 * Perl does the open, and hands script to suidperl on a fd;
3026 * suidperl only does some checks, sets up UIDs and re-execs
3027 * perl with that fd as it has always done.
3028 */
3029 }
3030 if (PL_suidscript != 1) {
3031 Perl_croak(aTHX_ "suidperl needs (suid) fd script\n");
3032 }
3033#else /* IAMSUID */
3280af22 3034 else if (PL_preprocess) {
46fc3d4c 3035 char *cpp_cfg = CPPSTDIN;
79cb57f6 3036 SV *cpp = newSVpvn("",0);
46fc3d4c 3037 SV *cmd = NEWSV(0,0);
3038
ae58f265
JH		 3039 if (cpp_cfg[0] == 0) /* PERL_MICRO? */
3040 Perl_croak(aTHX_ "Can't run with cpp -P with CPPSTDIN undefined");
46fc3d4c 3041 if (strEQ(cpp_cfg, "cppstdin"))
cea2e8a9 3042 Perl_sv_catpvf(aTHX_ cpp, "%s/", BIN_EXP);
46fc3d4c 3043 sv_catpv(cpp, cpp_cfg);
79072805 3044
1b24ed4b
MS		 3045# ifndef VMS
3046 sv_catpvn(sv, "-I", 2);
3047 sv_catpv(sv,PRIVLIB_EXP);
3048# endif
46fc3d4c 3049
14953ddc
MB		 3050 DEBUG_P(PerlIO_printf(Perl_debug_log,
3051 "PL_preprocess: scriptname=\"%s\", cpp=\"%s\", sv=\"%s\", CPPMINUS=\"%s\"\n",
3052 scriptname, SvPVX (cpp), SvPVX (sv), CPPMINUS));
1b24ed4b
MS		 3053
3054# if defined(MSDOS) || defined(WIN32) || defined(VMS)
3055 quote = "\"";
3056# else
3057 quote = "'";
3058# endif
3059
3060# ifdef VMS
3061 cpp_discard_flag = "";
3062# else
3063 cpp_discard_flag = "-C";
3064# endif
3065
3066# ifdef OS2
3067 perl = os2_execname(aTHX);
3068# else
3069 perl = PL_origargv[0];
3070# endif
3071
3072
3073 /* This strips off Perl comments which might interfere with
62375a60
NIS		 3074 the C pre-processor, including #!. #line directives are
3075 deliberately stripped to avoid confusion with Perl's version
1b24ed4b
MS		 3076 of #line. FWP played some golf with it so it will fit
3077 into VMS's 255 character buffer.
3078 */
3079 if( PL_doextract )
3080 code = "(1../^#!.*perl/i)|/^\\s*#(?!\\s*((ifn?|un)def|(el|end)?if|define|include|else|error|pragma)\\b)/||!($|=1)||print";
3081 else
3082 code = "/^\\s*#(?!\\s*((ifn?|un)def|(el|end)?if|define|include|else|error|pragma)\\b)/||!($|=1)||print";
3083
3084 Perl_sv_setpvf(aTHX_ cmd, "\
3085%s -ne%s%s%s %s | %"SVf" %s %"SVf" %s",
62375a60 3086 perl, quote, code, quote, scriptname, cpp,
1b24ed4b
MS		 3087 cpp_discard_flag, sv, CPPMINUS);
3088
3280af22 3089 PL_doextract = FALSE;
0a6c758d 3090
62375a60
NIS		 3091 DEBUG_P(PerlIO_printf(Perl_debug_log,
3092 "PL_preprocess: cmd=\"%s\"\n",
0a6c758d
MS		 3093 SvPVX(cmd)));
3094
3280af22 3095 PL_rsfp = PerlProc_popen(SvPVX(cmd), "r");
46fc3d4c 3096 SvREFCNT_dec(cmd);
3097 SvREFCNT_dec(cpp);
79072805
LW		 3098 }
3099 else if (!*scriptname) {
bbce6d69 3100 forbid_setid("program input from stdin");
3280af22 3101 PL_rsfp = PerlIO_stdin();
79072805 3102 }
96436eeb 3103 else {
3280af22 3104 PL_rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
1b24ed4b
MS		 3105# if defined(HAS_FCNTL) && defined(F_SETFD)
3106 if (PL_rsfp)
3107 /* ensure close-on-exec */
3108 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);
3109# endif
96436eeb 3110 }
ae3f3efd 3111#endif /* IAMSUID */
3280af22 3112 if (!PL_rsfp) {
447218f8 3113 /* PSz 16 Sep 03 Keep neat error message */
fa3aa65a
JC		 3114 Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
3115 CopFILE(PL_curcop), Strerror(errno));
13281fa4 3116 }
79072805 3117}
8d063cd8 3118
7b89560d
JH		 3119/* Mention
3120 * I_SYSSTATVFS HAS_FSTATVFS
3121 * I_SYSMOUNT
c890dc6c 3122 * I_STATFS HAS_FSTATFS HAS_GETFSSTAT
7b89560d
JH		 3123 * I_MNTENT HAS_GETMNTENT HAS_HASMNTOPT
3124 * here so that metaconfig picks them up. */
3125
104d25b7 3126#ifdef IAMSUID
864dbfa3 3127STATIC int
e688b231 3128S_fd_on_nosuid_fs(pTHX_ int fd)
104d25b7 3129{
ae3f3efd
PS		 3130/* PSz 27 Feb 04
3131 * We used to do this as "plain" user (after swapping UIDs with setreuid);
3132 * but is needed also on machines without setreuid.
3133 * Seems safe enough to run as root.
3134 */
0545a864
JH		 3135 int check_okay = 0; /* able to do all the required sys/libcalls */
3136 int on_nosuid = 0; /* the fd is on a nosuid fs */
ae3f3efd
PS		 3137 /* PSz 12 Nov 03
3138 * Need to check noexec also: nosuid might not be set, the average
3139 * sysadmin would say that nosuid is irrelevant once he sets noexec.
3140 */
3141 int on_noexec = 0; /* the fd is on a noexec fs */
3142
104d25b7 3143/*
ad27e871 3144 * Preferred order: fstatvfs(), fstatfs(), ustat()+getmnt(), getmntent().
e688b231 3145 * fstatvfs() is UNIX98.
0545a864 3146 * fstatfs() is 4.3 BSD.
ad27e871 3147 * ustat()+getmnt() is pre-4.3 BSD.
0545a864
JH		 3148 * getmntent() is O(number-of-mounted-filesystems) and can hang on
3149 * an irrelevant filesystem while trying to reach the right one.
104d25b7
JH		 3150 */
3151
6439433f
JH		 3152#undef FD_ON_NOSUID_CHECK_OKAY /* found the syscalls to do the check? */
3153
3154# if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
3155 defined(HAS_FSTATVFS)
3156# define FD_ON_NOSUID_CHECK_OKAY
104d25b7 3157 struct statvfs stfs;
6439433f 3158
104d25b7
JH		 3159 check_okay = fstatvfs(fd, &stfs) == 0;
3160 on_nosuid = check_okay && (stfs.f_flag & ST_NOSUID);
ae3f3efd
PS		 3161#ifdef ST_NOEXEC
3162 /* ST_NOEXEC certainly absent on AIX 5.1, and doesn't seem to be documented
3163 on platforms where it is present. */
3164 on_noexec = check_okay && (stfs.f_flag & ST_NOEXEC);
3165#endif
6439433f 3166# endif /* fstatvfs */
ac27b0f5 3167
6439433f
JH		 3168# if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
3169 defined(PERL_MOUNT_NOSUID) && \
ae3f3efd 3170 defined(PERL_MOUNT_NOEXEC) && \
6439433f
JH		 3171 defined(HAS_FSTATFS) && \
3172 defined(HAS_STRUCT_STATFS) && \
3173 defined(HAS_STRUCT_STATFS_F_FLAGS)
3174# define FD_ON_NOSUID_CHECK_OKAY
e688b231 3175 struct statfs stfs;
6439433f 3176
104d25b7 3177 check_okay = fstatfs(fd, &stfs) == 0;
104d25b7 3178 on_nosuid = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID);
ae3f3efd 3179 on_noexec = check_okay && (stfs.f_flags & PERL_MOUNT_NOEXEC);
6439433f
JH		 3180# endif /* fstatfs */
3181
3182# if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
3183 defined(PERL_MOUNT_NOSUID) && \
ae3f3efd 3184 defined(PERL_MOUNT_NOEXEC) && \
6439433f
JH		 3185 defined(HAS_FSTAT) && \
3186 defined(HAS_USTAT) && \
3187 defined(HAS_GETMNT) && \
3188 defined(HAS_STRUCT_FS_DATA) && \
3189 defined(NOSTAT_ONE)
3190# define FD_ON_NOSUID_CHECK_OKAY
c623ac67 3191 Stat_t fdst;
6439433f 3192
0545a864 3193 if (fstat(fd, &fdst) == 0) {
6439433f
JH		 3194 struct ustat us;
3195 if (ustat(fdst.st_dev, &us) == 0) {
3196 struct fs_data fsd;
3197 /* NOSTAT_ONE here because we're not examining fields which
3198 * vary between that case and STAT_ONE. */
ad27e871 3199 if (getmnt((int*)0, &fsd, (int)0, NOSTAT_ONE, us.f_fname) == 0) {
6439433f
JH		 3200 size_t cmplen = sizeof(us.f_fname);
3201 if (sizeof(fsd.fd_req.path) < cmplen)
3202 cmplen = sizeof(fsd.fd_req.path);
3203 if (strnEQ(fsd.fd_req.path, us.f_fname, cmplen) &&
3204 fdst.st_dev == fsd.fd_req.dev) {
3205 check_okay = 1;
3206 on_nosuid = fsd.fd_req.flags & PERL_MOUNT_NOSUID;
ae3f3efd 3207 on_noexec = fsd.fd_req.flags & PERL_MOUNT_NOEXEC;
6439433f
JH		 3208 }
3209 }
3210 }
3211 }
0545a864 3212 }
6439433f
JH		 3213# endif /* fstat+ustat+getmnt */
3214
3215# if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
3216 defined(HAS_GETMNTENT) && \
3217 defined(HAS_HASMNTOPT) && \
ae3f3efd
PS		 3218 defined(MNTOPT_NOSUID) && \
3219 defined(MNTOPT_NOEXEC)
6439433f
JH		 3220# define FD_ON_NOSUID_CHECK_OKAY
3221 FILE *mtab = fopen("/etc/mtab", "r");
3222 struct mntent *entry;
c623ac67 3223 Stat_t stb, fsb;
104d25b7
JH		 3224
3225 if (mtab && (fstat(fd, &stb) == 0)) {
6439433f
JH		 3226 while (entry = getmntent(mtab)) {
3227 if (stat(entry->mnt_dir, &fsb) == 0
3228 && fsb.st_dev == stb.st_dev)
3229 {
3230 /* found the filesystem */
3231 check_okay = 1;
3232 if (hasmntopt(entry, MNTOPT_NOSUID))
3233 on_nosuid = 1;
ae3f3efd
PS		 3234 if (hasmntopt(entry, MNTOPT_NOEXEC))
3235 on_noexec = 1;
6439433f
JH		 3236 break;
3237 } /* A single fs may well fail its stat(). */
3238 }
104d25b7
JH		 3239 }
3240 if (mtab)
6439433f
JH		 3241 fclose(mtab);
3242# endif /* getmntent+hasmntopt */
0545a864 3243
ac27b0f5 3244 if (!check_okay)
ae3f3efd
PS		 3245 Perl_croak(aTHX_ "Can't check filesystem of script \"%s\" for nosuid/noexec", PL_origfilename);
3246 if (on_nosuid)
3247 Perl_croak(aTHX_ "Setuid script \"%s\" on nosuid filesystem", PL_origfilename);
3248 if (on_noexec)
3249 Perl_croak(aTHX_ "Setuid script \"%s\" on noexec filesystem", PL_origfilename);
3250 return ((!check_okay) || on_nosuid || on_noexec);
104d25b7
JH		 3251}
3252#endif /* IAMSUID */
3253
76e3520e 3254STATIC void
c5cccb17 3255S_validate_suid(pTHX_ char *validarg, char *scriptname)
79072805 3256{
155aba94 3257#ifdef IAMSUID
ae3f3efd
PS		 3258 /* int which; */
3259#endif /* IAMSUID */
96436eeb 3260
13281fa4
LW		 3261 /* do we need to emulate setuid on scripts? */
3262
3263 /* This code is for those BSD systems that have setuid #! scripts disabled
3264 * in the kernel because of a security problem. Merely defining DOSUID
3265 * in perl will not fix that problem, but if you have disabled setuid
3266 * scripts in the kernel, this will attempt to emulate setuid and setgid
3267 * on scripts that have those now-otherwise-useless bits set. The setuid
27e2fb84
LW		 3268 * root version must be called suidperl or sperlN.NNN. If regular perl
3269 * discovers that it has opened a setuid script, it calls suidperl with
3270 * the same argv that it had. If suidperl finds that the script it has
3271 * just opened is NOT setuid root, it sets the effective uid back to the
3272 * uid. We don't just make perl setuid root because that loses the
3273 * effective uid we had before invoking perl, if it was different from the
3274 * uid.
ae3f3efd
PS		 3275 * PSz 27 Feb 04
3276 * Description/comments above do not match current workings:
3277 * suidperl must be hardlinked to sperlN.NNN (that is what we exec);
3278 * suidperl called with script open and name changed to /dev/fd/N/X;
3279 * suidperl croaks if script is not setuid;
3280 * making perl setuid would be a huge security risk (and yes, that
3281 * would lose any euid we might have had).
13281fa4
LW		 3282 *
3283 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
3284 * be defined in suidperl only. suidperl must be setuid root. The
3285 * Configure script will set this up for you if you want it.
3286 */
a687059c 3287
13281fa4 3288#ifdef DOSUID
6e72f9df 3289 char *s, *s2;
a0d0e21e 3290
b28d0864 3291 if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0) /* normal stat is insecure */
cea2e8a9 3292 Perl_croak(aTHX_ "Can't stat script \"%s\"",PL_origfilename);
ae3f3efd 3293 if (PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
79072805 3294 I32 len;
2d8e6c8d 3295 STRLEN n_a;
13281fa4 3296
a687059c 3297#ifdef IAMSUID
ae3f3efd
PS		 3298 if (PL_fdscript < 0 || PL_suidscript != 1)
3299 Perl_croak(aTHX_ "Need (suid) fdscript in suidperl\n"); /* We already checked this */
3300 /* PSz 11 Nov 03
3301 * Since the script is opened by perl, not suidperl, some of these
3302 * checks are superfluous. Leaving them in probably does not lower
3303 * security(?!).
3304 */
3305 /* PSz 27 Feb 04
3306 * Do checks even for systems with no HAS_SETREUID.
3307 * We used to swap, then re-swap UIDs with
3308#ifdef HAS_SETREUID
3309 if (setreuid(PL_euid,PL_uid) < 0
3310 || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
3311 Perl_croak(aTHX_ "Can't swap uid and euid");
3312#endif
3313#ifdef HAS_SETREUID
3314 if (setreuid(PL_uid,PL_euid) < 0
3315 || PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid)
3316 Perl_croak(aTHX_ "Can't reswap uid and euid");
3317#endif
3318 */
3319
a687059c
LW		 3320 /* On this access check to make sure the directories are readable,
3321 * there is actually a small window that the user could use to make
3322 * filename point to an accessible directory. So there is a faint
3323 * chance that someone could execute a setuid script down in a
3324 * non-accessible directory. I don't know what to do about that.
3325 * But I don't think it's too important. The manual lies when
3326 * it says access() is useful in setuid programs.
ae3f3efd
PS		 3327 *
3328 * So, access() is pretty useless... but not harmful... do anyway.
a687059c 3329 */
e57400b1 3330 if (PerlLIO_access(CopFILE(PL_curcop),1)) { /*double check*/
ae3f3efd 3331 Perl_croak(aTHX_ "Can't access() script\n");
e57400b1 3332 }
ae3f3efd 3333
a687059c
LW		 3334 /* If we can swap euid and uid, then we can determine access rights
3335 * with a simple stat of the file, and then compare device and
3336 * inode to make sure we did stat() on the same file we opened.
3337 * Then we just have to make sure he or she can execute it.
ae3f3efd
PS		 3338 *
3339 * PSz 24 Feb 04
3340 * As the script is opened by perl, not suidperl, we do not need to
3341 * care much about access rights.
3342 *
3343 * The 'script changed' check is needed, or we can get lied to
3344 * about $0 with e.g.
3345 * suidperl /dev/fd/4//bin/x 4<setuidscript
3346 * Without HAS_SETREUID, is it safe to stat() as root?
3347 *
3348 * Are there any operating systems that pass /dev/fd/xxx for setuid
3349 * scripts, as suggested/described in perlsec(1)? Surely they do not
3350 * pass the script name as we do, so the "script changed" test would
3351 * fail for them... but we never get here with
3352 * SETUID_SCRIPTS_ARE_SECURE_NOW defined.
3353 *
3354 * This is one place where we must "lie" about return status: not
3355 * say if the stat() failed. We are doing this as root, and could
3356 * be tricked into reporting existence or not of files that the
3357 * "plain" user cannot even see.
a687059c
LW		 3358 */
3359 {
c623ac67 3360 Stat_t tmpstatbuf;
ae3f3efd
PS		 3361 if (PerlLIO_stat(CopFILE(PL_curcop),&tmpstatbuf) < 0 ||
3362 tmpstatbuf.st_dev != PL_statbuf.st_dev ||
b28d0864 3363 tmpstatbuf.st_ino != PL_statbuf.st_ino) {
ae3f3efd 3364 Perl_croak(aTHX_ "Setuid script changed\n");
a687059c 3365 }
ae3f3efd 3366
a687059c 3367 }
ae3f3efd
PS		 3368 if (!cando(S_IXUSR,FALSE,&PL_statbuf)) /* can real uid exec? */
3369 Perl_croak(aTHX_ "Real UID cannot exec script\n");
3370
3371 /* PSz 27 Feb 04
3372 * We used to do this check as the "plain" user (after swapping
3373 * UIDs). But the check for nosuid and noexec filesystem is needed,
3374 * and should be done even without HAS_SETREUID. (Maybe those
3375 * operating systems do not have such mount options anyway...)
3376 * Seems safe enough to do as root.
3377 */
3378#if !defined(NO_NOSUID_CHECK)
3379 if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp))) {
3380 Perl_croak(aTHX_ "Setuid script on nosuid or noexec filesystem\n");
3381 }
3382#endif
a687059c
LW		 3383#endif /* IAMSUID */
3384
e57400b1 3385 if (!S_ISREG(PL_statbuf.st_mode)) {
ae3f3efd 3386 Perl_croak(aTHX_ "Setuid script not plain file\n");
e57400b1 3387 }
b28d0864 3388 if (PL_statbuf.st_mode & S_IWOTH)
cea2e8a9 3389 Perl_croak(aTHX_ "Setuid/gid script is writable by world");
6b88bc9c 3390 PL_doswitches = FALSE; /* -s is insecure in suid */
ae3f3efd 3391 /* PSz 13 Nov 03 But -s was caught elsewhere ... so unsetting it here is useless(?!) */
57843af0 3392 CopLINE_inc(PL_curcop);
6b88bc9c 3393 if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch ||
2d8e6c8d 3394 strnNE(SvPV(PL_linestr,n_a),"#!",2) ) /* required even on Sys V */
cea2e8a9 3395 Perl_croak(aTHX_ "No #! line");
2d8e6c8d 3396 s = SvPV(PL_linestr,n_a)+2;
ae3f3efd
PS		 3397 /* PSz 27 Feb 04 */
3398 /* Sanity check on line length */
3399 if (strlen(s) < 1 || strlen(s) > 4000)
3400 Perl_croak(aTHX_ "Very long #! line");
3401 /* Allow more than a single space after #! */
3402 while (isSPACE(*s)) s++;
3403 /* Sanity check on buffer end */
3404 while ((*s) && !isSPACE(*s)) s++;
2d8e6c8d 3405 for (s2 = s; (s2 > SvPV(PL_linestr,n_a)+2 &&
3792a11b
NC		 3406 (isDIGIT(s2[-1]) || s2[-1] == '.' || s2[-1] == '_'
3407 || s2[-1] == '-')); s2--) ;
ae3f3efd
PS		 3408 /* Sanity check on buffer start */
3409 if ( (s2-4 < SvPV(PL_linestr,n_a)+2 || strnNE(s2-4,"perl",4)) &&
3410 (s-9 < SvPV(PL_linestr,n_a)+2 || strnNE(s-9,"perl",4)) )
cea2e8a9 3411 Perl_croak(aTHX_ "Not a perl script");
a687059c 3412 while (*s == ' ' || *s == '\t') s++;
13281fa4
LW		 3413 /*
3414 * #! arg must be what we saw above. They can invoke it by
3415 * mentioning suidperl explicitly, but they may not add any strange
3416 * arguments beyond what #! says if they do invoke suidperl that way.
3417 */
ae3f3efd
PS		 3418 /*
3419 * The way validarg was set up, we rely on the kernel to start
3420 * scripts with argv[1] set to contain all #! line switches (the
3421 * whole line).
3422 */
3423 /*
3424 * Check that we got all the arguments listed in the #! line (not
3425 * just that there are no extraneous arguments). Might not matter
3426 * much, as switches from #! line seem to be acted upon (also), and
3427 * so may be checked and trapped in perl. But, security checks must
3428 * be done in suidperl and not deferred to perl. Note that suidperl
3429 * does not get around to parsing (and checking) the switches on
3430 * the #! line (but execs perl sooner).
3431 * Allow (require) a trailing newline (which may be of two
3432 * characters on some architectures?) (but no other trailing
3433 * whitespace).
3434 */
13281fa4
LW		 3435 len = strlen(validarg);
3436 if (strEQ(validarg," PHOOEY ") ||
ae3f3efd
PS		 3437 strnNE(s,validarg,len) || !isSPACE(s[len]) ||
3438 !(strlen(s) == len+1 || (strlen(s) == len+2 && isSPACE(s[len+1]))))
cea2e8a9 3439 Perl_croak(aTHX_ "Args must match #! line");
a687059c
LW		 3440
3441#ifndef IAMSUID
ae3f3efd
PS		 3442 if (PL_fdscript < 0 &&
3443 PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
b28d0864
NIS		 3444 PL_euid == PL_statbuf.st_uid)
3445 if (!PL_do_undump)
cea2e8a9 3446 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
11fb1898 3447FIX YOUR KERNEL, OR PUT A C WRAPPER AROUND THIS SCRIPT!\n");
a687059c 3448#endif /* IAMSUID */
13281fa4 3449
ae3f3efd
PS		 3450 if (PL_fdscript < 0 &&
3451 PL_euid) { /* oops, we're not the setuid root perl */
3452 /* PSz 18 Feb 04
3453 * When root runs a setuid script, we do not go through the same
3454 * steps of execing sperl and then perl with fd scripts, but
3455 * simply set up UIDs within the same perl invocation; so do
3456 * not have the same checks (on options, whatever) that we have
3457 * for plain users. No problem really: would have to be a script
3458 * that does not actually work for plain users; and if root is
3459 * foolish and can be persuaded to run such an unsafe script, he
3460 * might run also non-setuid ones, and deserves what he gets.
3461 *
3462 * Or, we might drop the PL_euid check above (and rely just on
3463 * PL_fdscript to avoid loops), and do the execs
3464 * even for root.
3465 */
13281fa4 3466#ifndef IAMSUID
ae3f3efd
PS		 3467 int which;
3468 /* PSz 11 Nov 03
3469 * Pass fd script to suidperl.
3470 * Exec suidperl, substituting fd script for scriptname.
3471 * Pass script name as "subdir" of fd, which perl will grok;
3472 * in fact will use that to distinguish this from "normal"
3473 * usage, see comments above.
3474 */
3475 PerlIO_rewind(PL_rsfp);
3476 PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0); /* just in case rewind didn't */
3477 /* PSz 27 Feb 04 Sanity checks on scriptname */
3478 if ((!scriptname) || (!*scriptname) ) {
3479 Perl_croak(aTHX_ "No setuid script name\n");
3480 }
3481 if (*scriptname == '-') {
3482 Perl_croak(aTHX_ "Setuid script name may not begin with dash\n");
3483 /* Or we might confuse it with an option when replacing
3484 * name in argument list, below (though we do pointer, not
3485 * string, comparisons).
3486 */
3487 }
3488 for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;
3489 if (!PL_origargv[which]) {
3490 Perl_croak(aTHX_ "Can't change argv to have fd script\n");
3491 }
3492 PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s",
3493 PerlIO_fileno(PL_rsfp), PL_origargv[which]));
3494#if defined(HAS_FCNTL) && defined(F_SETFD)
3495 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0); /* ensure no close-on-exec */
3496#endif
b35112e7 3497 PERL_FPU_PRE_EXEC
a7cb1f99 3498 PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, BIN_EXP,
273cf8d1
GS		 3499 (int)PERL_REVISION, (int)PERL_VERSION,
3500 (int)PERL_SUBVERSION), PL_origargv);
b35112e7 3501 PERL_FPU_POST_EXEC
ae3f3efd
PS		 3502#endif /* IAMSUID */
3503 Perl_croak(aTHX_ "Can't do setuid (cannot exec sperl)\n");
13281fa4
LW		 3504 }
3505
b28d0864 3506 if (PL_statbuf.st_mode & S_ISGID && PL_statbuf.st_gid != PL_egid) {
ae3f3efd
PS		 3507/* PSz 26 Feb 04
3508 * This seems back to front: we try HAS_SETEGID first; if not available
3509 * then try HAS_SETREGID; as a last chance we try HAS_SETRESGID. May be OK
3510 * in the sense that we only want to set EGID; but are there any machines
3511 * with either of the latter, but not the former? Same with UID, later.
3512 */
fe14fcc3 3513#ifdef HAS_SETEGID
b28d0864 3514 (void)setegid(PL_statbuf.st_gid);
a687059c 3515#else
fe14fcc3 3516#ifdef HAS_SETREGID
b28d0864 3517 (void)setregid((Gid_t)-1,PL_statbuf.st_gid);
85e6fe83
LW		 3518#else
3519#ifdef HAS_SETRESGID
b28d0864 3520 (void)setresgid((Gid_t)-1,PL_statbuf.st_gid,(Gid_t)-1);
a687059c 3521#else
b28d0864 3522 PerlProc_setgid(PL_statbuf.st_gid);
a687059c
LW		 3523#endif
3524#endif
85e6fe83 3525#endif
b28d0864 3526 if (PerlProc_getegid() != PL_statbuf.st_gid)
cea2e8a9 3527 Perl_croak(aTHX_ "Can't do setegid!\n");
83025b21 3528 }
b28d0864
NIS		 3529 if (PL_statbuf.st_mode & S_ISUID) {
3530 if (PL_statbuf.st_uid != PL_euid)
fe14fcc3 3531#ifdef HAS_SETEUID
b28d0864 3532 (void)seteuid(PL_statbuf.st_uid); /* all that for this */
a687059c 3533#else
fe14fcc3 3534#ifdef HAS_SETREUID
b28d0864 3535 (void)setreuid((Uid_t)-1,PL_statbuf.st_uid);
85e6fe83
LW		 3536#else
3537#ifdef HAS_SETRESUID
b28d0864 3538 (void)setresuid((Uid_t)-1,PL_statbuf.st_uid,(Uid_t)-1);
a687059c 3539#else
b28d0864 3540 PerlProc_setuid(PL_statbuf.st_uid);
a687059c
LW		 3541#endif
3542#endif
85e6fe83 3543#endif
b28d0864 3544 if (PerlProc_geteuid() != PL_statbuf.st_uid)
cea2e8a9 3545 Perl_croak(aTHX_ "Can't do seteuid!\n");
a687059c 3546 }
b28d0864 3547 else if (PL_uid) { /* oops, mustn't run as root */
fe14fcc3 3548#ifdef HAS_SETEUID
b28d0864 3549 (void)seteuid((Uid_t)PL_uid);
a687059c 3550#else
fe14fcc3 3551#ifdef HAS_SETREUID
b28d0864 3552 (void)setreuid((Uid_t)-1,(Uid_t)PL_uid);
a687059c 3553#else
85e6fe83 3554#ifdef HAS_SETRESUID
b28d0864 3555 (void)setresuid((Uid_t)-1,(Uid_t)PL_uid,(Uid_t)-1);
85e6fe83 3556#else
b28d0864 3557 PerlProc_setuid((Uid_t)PL_uid);
85e6fe83 3558#endif
a687059c
LW		 3559#endif
3560#endif
b28d0864 3561 if (PerlProc_geteuid() != PL_uid)
cea2e8a9 3562 Perl_croak(aTHX_ "Can't do seteuid!\n");
83025b21 3563 }
748a9306 3564 init_ids();
b28d0864 3565 if (!cando(S_IXUSR,TRUE,&PL_statbuf))
ae3f3efd 3566 Perl_croak(aTHX_ "Effective UID cannot exec script\n"); /* they can't do this */
13281fa4
LW		 3567 }
3568#ifdef IAMSUID
ae3f3efd 3569 else if (PL_preprocess) /* PSz 13 Nov 03 Caught elsewhere, useless(?!) here */
cea2e8a9 3570 Perl_croak(aTHX_ "-P not allowed for setuid/setgid script\n");
ae3f3efd
PS		 3571 else if (PL_fdscript < 0 || PL_suidscript != 1)
3572 /* PSz 13 Nov 03 Caught elsewhere, useless(?!) here */
3573 Perl_croak(aTHX_ "(suid) fdscript needed in suidperl\n");
e57400b1 3574 else {
ae3f3efd
PS		 3575/* PSz 16 Sep 03 Keep neat error message */
3576 Perl_croak(aTHX_ "Script is not setuid/setgid in suidperl\n");
e57400b1 3577 }
96436eeb 3578
3579 /* We absolutely must clear out any saved ids here, so we */
3580 /* exec the real perl, substituting fd script for scriptname. */
3581 /* (We pass script name as "subdir" of fd, which perl will grok.) */
ae3f3efd
PS		 3582 /*
3583 * It might be thought that using setresgid and/or setresuid (changed to
3584 * set the saved IDs) above might obviate the need to exec, and we could
3585 * go on to "do the perl thing".
3586 *
3587 * Is there such a thing as "saved GID", and is that set for setuid (but
3588 * not setgid) execution like suidperl? Without exec, it would not be
3589 * cleared for setuid (but not setgid) scripts (or might need a dummy
3590 * setresgid).
3591 *
3592 * We need suidperl to do the exact same argument checking that perl
3593 * does. Thus it cannot be very small; while it could be significantly
3594 * smaller, it is safer (simpler?) to make it essentially the same
3595 * binary as perl (but they are not identical). - Maybe could defer that
3596 * check to the invoked perl, and suidperl be a tiny wrapper instead;
3597 * but prefer to do thorough checks in suidperl itself. Such deferral
3598 * would make suidperl security rely on perl, a design no-no.
3599 *
3600 * Setuid things should be short and simple, thus easy to understand and
3601 * verify. They should do their "own thing", without influence by
3602 * attackers. It may help if their internal execution flow is fixed,
3603 * regardless of platform: it may be best to exec anyway.
3604 *
3605 * Suidperl should at least be conceptually simple: a wrapper only,
3606 * never to do any real perl. Maybe we should put
3607 * #ifdef IAMSUID
3608 * Perl_croak(aTHX_ "Suidperl should never do real perl\n");
3609 * #endif
3610 * into the perly bits.
3611 */
b28d0864
NIS		 3612 PerlIO_rewind(PL_rsfp);
3613 PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0); /* just in case rewind didn't */
ae3f3efd
PS		 3614 /* PSz 11 Nov 03
3615 * Keep original arguments: suidperl already has fd script.
3616 */
3617/* for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ; */
3618/* if (!PL_origargv[which]) { */
3619/* errno = EPERM; */
3620/* Perl_croak(aTHX_ "Permission denied\n"); */
3621/* } */
3622/* PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s", */
3623/* PerlIO_fileno(PL_rsfp), PL_origargv[which])); */
96436eeb 3624#if defined(HAS_FCNTL) && defined(F_SETFD)
b28d0864 3625 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0); /* ensure no close-on-exec */
96436eeb 3626#endif
b35112e7 3627 PERL_FPU_PRE_EXEC
a7cb1f99 3628 PerlProc_execv(Perl_form(aTHX_ "%s/perl"PERL_FS_VER_FMT, BIN_EXP,
273cf8d1
GS		 3629 (int)PERL_REVISION, (int)PERL_VERSION,
3630 (int)PERL_SUBVERSION), PL_origargv);/* try again */
b35112e7 3631 PERL_FPU_POST_EXEC
ae3f3efd 3632 Perl_croak(aTHX_ "Can't do setuid (suidperl cannot exec perl)\n");
13281fa4 3633#endif /* IAMSUID */
a687059c 3634#else /* !DOSUID */
3280af22 3635 if (PL_euid != PL_uid || PL_egid != PL_gid) { /* (suidperl doesn't exist, in fact) */
a687059c 3636#ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
b28d0864
NIS		 3637 PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf); /* may be either wrapped or real suid */
3638 if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
a687059c 3639 ||
b28d0864 3640 (PL_egid != PL_gid && PL_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
a687059c 3641 )
b28d0864 3642 if (!PL_do_undump)
cea2e8a9 3643 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
a687059c
LW		 3644FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
3645#endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
3646 /* not set-id, must be wrapped */
a687059c 3647 }
13281fa4 3648#endif /* DOSUID */
79072805 3649}
13281fa4 3650
76e3520e 3651STATIC void
cea2e8a9 3652S_find_beginning(pTHX)
79072805 3653{
6e72f9df 3654 register char *s, *s2;
e55ac0fa
HS		 3655#ifdef MACOS_TRADITIONAL
3656 int maclines = 0;
3657#endif
33b78306
LW		 3658
3659 /* skip forward in input to the real script? */
3660
bbce6d69 3661 forbid_setid("-x");
bf4acbe4 3662#ifdef MACOS_TRADITIONAL
084592ab 3663 /* Since the Mac OS does not honor #! arguments for us, we do it ourselves */
ac27b0f5 3664
bf4acbe4
GS		 3665 while (PL_doextract || gMacPerl_AlwaysExtract) {
3666 if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
3667 if (!gMacPerl_AlwaysExtract)
3668 Perl_croak(aTHX_ "No Perl script found in input\n");
e55ac0fa 3669
bf4acbe4
GS		 3670 if (PL_doextract) /* require explicit override ? */
3671 if (!OverrideExtract(PL_origfilename))
3672 Perl_croak(aTHX_ "User aborted script\n");
3673 else
3674 PL_doextract = FALSE;
e55ac0fa 3675
bf4acbe4
GS		 3676 /* Pater peccavi, file does not have #! */
3677 PerlIO_rewind(PL_rsfp);
e55ac0fa 3678
bf4acbe4
GS		 3679 break;
3680 }
3681#else
3280af22
NIS		 3682 while (PL_doextract) {
3683 if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch)
cea2e8a9 3684 Perl_croak(aTHX_ "No Perl script found in input\n");
bf4acbe4 3685#endif
4f0c37ba
IZ		 3686 s2 = s;
3687 if (*s == '#' && s[1] == '!' && ((s = instr(s,"perl")) || (s = instr(s2,"PERL")))) {
3280af22
NIS		 3688 PerlIO_ungetc(PL_rsfp, '\n'); /* to keep line count right */
3689 PL_doextract = FALSE;
6e72f9df 3690 while (*s && !(isSPACE (*s) || *s == '#')) s++;
3691 s2 = s;
3692 while (*s == ' ' || *s == '\t') s++;
3693 if (*s++ == '-') {
3792a11b
NC		 3694 while (isDIGIT(s2[-1]) || s2[-1] == '-' || s2[-1] == '.'
3695 || s2[-1] == '_') s2--;
6e72f9df 3696 if (strnEQ(s2-4,"perl",4))
3697 /*SUPPRESS 530*/
155aba94
GS		 3698 while ((s = moreswitches(s)))
3699 ;
33b78306 3700 }
95e8664e 3701#ifdef MACOS_TRADITIONAL
e55ac0fa
HS		 3702 /* We are always searching for the #!perl line in MacPerl,
3703 * so if we find it, still keep the line count correct
3704 * by counting lines we already skipped over
3705 */
3706 for (; maclines > 0 ; maclines--)
3707 PerlIO_ungetc(PL_rsfp, '\n');
3708
95e8664e 3709 break;
e55ac0fa
HS		 3710
3711 /* gMacPerl_AlwaysExtract is false in MPW tool */
3712 } else if (gMacPerl_AlwaysExtract) {
3713 ++maclines;
95e8664e 3714#endif
83025b21
LW		 3715 }
3716 }
3717}
3718
afe37c7d 3719
76e3520e 3720STATIC void
cea2e8a9 3721S_init_ids(pTHX)
352d5a3a 3722{
d8eceb89
JH		 3723 PL_uid = PerlProc_getuid();
3724 PL_euid = PerlProc_geteuid();
3725 PL_gid = PerlProc_getgid();
3726 PL_egid = PerlProc_getegid();
748a9306 3727#ifdef VMS
b28d0864
NIS		 3728 PL_uid |= PL_gid << 16;
3729 PL_euid |= PL_egid << 16;
748a9306 3730#endif
22f7c9c9
JH		 3731 /* Should not happen: */
3732 CHECK_MALLOC_TAINT(PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
3280af22 3733 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
ae3f3efd
PS		 3734 /* BUG */
3735 /* PSz 27 Feb 04
3736 * Should go by suidscript, not uid!=euid: why disallow
3737 * system("ls") in scripts run from setuid things?
3738 * Or, is this run before we check arguments and set suidscript?
3739 * What about SETUID_SCRIPTS_ARE_SECURE_NOW: could we use fdscript then?
3740 * (We never have suidscript, can we be sure to have fdscript?)
3741 * Or must then go by UID checks? See comments in forbid_setid also.
3742 */
748a9306 3743}
79072805 3744
a0643315
JH		 3745/* This is used very early in the lifetime of the program,
3746 * before even the options are parsed, so PL_tainting has
b0891165 3747 * not been initialized properly. */
af419de7 3748bool
22f7c9c9
JH		 3749Perl_doing_taint(int argc, char *argv[], char *envp[])
3750{
c3446a78
JH		 3751#ifndef PERL_IMPLICIT_SYS
3752 /* If we have PERL_IMPLICIT_SYS we can't call getuid() et alia
3753 * before we have an interpreter-- and the whole point of this
3754 * function is to be called at such an early stage. If you are on
3755 * a system with PERL_IMPLICIT_SYS but you do have a concept of
3756 * "tainted because running with altered effective ids', you'll
3757 * have to add your own checks somewhere in here. The two most
3758 * known samples of 'implicitness' are Win32 and NetWare, neither
3759 * of which has much of concept of 'uids'. */
af419de7 3760 int uid = PerlProc_getuid();
22f7c9c9 3761 int euid = PerlProc_geteuid();
af419de7 3762 int gid = PerlProc_getgid();
22f7c9c9
JH		 3763 int egid = PerlProc_getegid();
3764
3765#ifdef VMS
af419de7 3766 uid |= gid << 16;
22f7c9c9
JH		 3767 euid |= egid << 16;
3768#endif
3769 if (uid && (euid != uid || egid != gid))
3770 return 1;
c3446a78 3771#endif /* !PERL_IMPLICIT_SYS */
af419de7
JH		 3772 /* This is a really primitive check; environment gets ignored only
3773 * if -T are the first chars together; otherwise one gets
3774 * "Too late" message. */
22f7c9c9
JH		 3775 if ( argc > 1 && argv[1][0] == '-'
3776 && (argv[1][1] == 't' || argv[1][1] == 'T') )
3777 return 1;
3778 return 0;
3779}
22f7c9c9 3780
76e3520e 3781STATIC void
cea2e8a9 3782S_forbid_setid(pTHX_ char *s)
bbce6d69 3783{
ae3f3efd 3784#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
3280af22 3785 if (PL_euid != PL_uid)
cea2e8a9 3786 Perl_croak(aTHX_ "No %s allowed while running setuid", s);
3280af22 3787 if (PL_egid != PL_gid)
cea2e8a9 3788 Perl_croak(aTHX_ "No %s allowed while running setgid", s);
ae3f3efd
PS		 3789#endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
3790 /* PSz 29 Feb 04
3791 * Checks for UID/GID above "wrong": why disallow
3792 * perl -e 'print "Hello\n"'
3793 * from within setuid things?? Simply drop them: replaced by
3794 * fdscript/suidscript and #ifdef IAMSUID checks below.
3795 *
3796 * This may be too late for command-line switches. Will catch those on
3797 * the #! line, after finding the script name and setting up
3798 * fdscript/suidscript. Note that suidperl does not get around to
3799 * parsing (and checking) the switches on the #! line, but checks that
3800 * the two sets are identical.
3801 *
3802 * With SETUID_SCRIPTS_ARE_SECURE_NOW, could we use fdscript, also or
3803 * instead, or would that be "too late"? (We never have suidscript, can
3804 * we be sure to have fdscript?)
3805 *
3806 * Catch things with suidscript (in descendant of suidperl), even with
3807 * right UID/GID. Was already checked in suidperl, with #ifdef IAMSUID,
3808 * below; but I am paranoid.
3809 *
3810 * Also see comments about root running a setuid script, elsewhere.
3811 */
3812 if (PL_suidscript >= 0)
3813 Perl_croak(aTHX_ "No %s allowed with (suid) fdscript", s);
3814#ifdef IAMSUID
3815 /* PSz 11 Nov 03 Catch it in suidperl, always! */
3816 Perl_croak(aTHX_ "No %s allowed in suidperl", s);
3817#endif /* IAMSUID */
bbce6d69 3818}
3819
1ee4443e
IZ		 3820void
3821Perl_init_debugger(pTHX)
748a9306 3822{
1ee4443e
IZ		 3823 HV *ostash = PL_curstash;
3824
3280af22 3825 PL_curstash = PL_debstash;
7619c85e 3826 PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("DB::args", GV_ADDMULTI, SVt_PVAV))));
3280af22 3827 AvREAL_off(PL_dbargs);
7619c85e
RG		 3828 PL_DBgv = gv_fetchpv("DB::DB", GV_ADDMULTI, SVt_PVGV);
3829 PL_DBline = gv_fetchpv("DB::dbline", GV_ADDMULTI, SVt_PVAV);
3830 PL_DBsub = gv_HVadd(gv_fetchpv("DB::sub", GV_ADDMULTI, SVt_PVHV));
1ee4443e 3831 sv_upgrade(GvSV(PL_DBsub), SVt_IV); /* IVX accessed if PERLDB_SUB_NN */
7619c85e 3832 PL_DBsingle = GvSV((gv_fetchpv("DB::single", GV_ADDMULTI, SVt_PV)));
ac27b0f5 3833 sv_setiv(PL_DBsingle, 0);
7619c85e 3834 PL_DBtrace = GvSV((gv_fetchpv("DB::trace", GV_ADDMULTI, SVt_PV)));
ac27b0f5 3835 sv_setiv(PL_DBtrace, 0);
7619c85e 3836 PL_DBsignal = GvSV((gv_fetchpv("DB::signal", GV_ADDMULTI, SVt_PV)));
ac27b0f5 3837 sv_setiv(PL_DBsignal, 0);
bf9cdc68 3838 PL_DBassertion = GvSV((gv_fetchpv("DB::assertion", GV_ADDMULTI, SVt_PV)));
06492da6 3839 sv_setiv(PL_DBassertion, 0);
1ee4443e 3840 PL_curstash = ostash;
352d5a3a
LW		 3841}
3842
2ce36478
SM		 3843#ifndef STRESS_REALLOC
3844#define REASONABLE(size) (size)
3845#else
3846#define REASONABLE(size) (1) /* unreasonable */
3847#endif
3848
11343788 3849void
cea2e8a9 3850Perl_init_stacks(pTHX)
79072805 3851{
e336de0d 3852 /* start with 128-item stack and 8K cxstack */
3280af22 3853 PL_curstackinfo = new_stackinfo(REASONABLE(128),
e336de0d 3854 REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
3280af22
NIS		 3855 PL_curstackinfo->si_type = PERLSI_MAIN;
3856 PL_curstack = PL_curstackinfo->si_stack;
3857 PL_mainstack = PL_curstack; /* remember in case we switch stacks */
79072805 3858
3280af22
NIS		 3859 PL_stack_base = AvARRAY(PL_curstack);
3860 PL_stack_sp = PL_stack_base;
3861 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
8990e307 3862
3280af22
NIS		 3863 New(50,PL_tmps_stack,REASONABLE(128),SV*);
3864 PL_tmps_floor = -1;
3865 PL_tmps_ix = -1;
3866 PL_tmps_max = REASONABLE(128);
8990e307 3867
3280af22
NIS		 3868 New(54,PL_markstack,REASONABLE(32),I32);
3869 PL_markstack_ptr = PL_markstack;
3870 PL_markstack_max = PL_markstack + REASONABLE(32);
79072805 3871
ce2f7c3b 3872 SET_MARK_OFFSET;
e336de0d 3873
3280af22
NIS		 3874 New(54,PL_scopestack,REASONABLE(32),I32);
3875 PL_scopestack_ix = 0;
3876 PL_scopestack_max = REASONABLE(32);
79072805 3877
3280af22
NIS		 3878 New(54,PL_savestack,REASONABLE(128),ANY);
3879 PL_savestack_ix = 0;
3880 PL_savestack_max = REASONABLE(128);
378cc40b 3881}
33b78306 3882
2ce36478
SM		 3883#undef REASONABLE
3884
76e3520e 3885STATIC void
cea2e8a9 3886S_nuke_stacks(pTHX)
6e72f9df 3887{
3280af22
NIS		 3888 while (PL_curstackinfo->si_next)
3889 PL_curstackinfo = PL_curstackinfo->si_next;
3890 while (PL_curstackinfo) {
3891 PERL_SI *p = PL_curstackinfo->si_prev;
bac4b2ad 3892 /* curstackinfo->si_stack got nuked by sv_free_arenas() */
3280af22
NIS		 3893 Safefree(PL_curstackinfo->si_cxstack);
3894 Safefree(PL_curstackinfo);
3895 PL_curstackinfo = p;
e336de0d 3896 }
3280af22
NIS		 3897 Safefree(PL_tmps_stack);
3898 Safefree(PL_markstack);
3899 Safefree(PL_scopestack);
3900 Safefree(PL_savestack);
378cc40b 3901}
33b78306 3902
76e3520e 3903STATIC void
cea2e8a9 3904S_init_lexer(pTHX)
8990e307 3905{
06039172 3906 PerlIO *tmpfp;
3280af22
NIS		 3907 tmpfp = PL_rsfp;
3908 PL_rsfp = Nullfp;
3909 lex_start(PL_linestr);
3910 PL_rsfp = tmpfp;
79cb57f6 3911 PL_subname = newSVpvn("main",4);
8990e307
LW		 3912}
3913
76e3520e 3914STATIC void
cea2e8a9 3915S_init_predump_symbols(pTHX)
45d8adaa 3916{
93a17b20 3917 GV *tmpgv;
af8c498a 3918 IO *io;
79072805 3919
864dbfa3 3920 sv_setpvn(get_sv("\"", TRUE), " ", 1);
3280af22
NIS		 3921 PL_stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
3922 GvMULTI_on(PL_stdingv);
af8c498a 3923 io = GvIOp(PL_stdingv);
a04651f4 3924 IoTYPE(io) = IoTYPE_RDONLY;
af8c498a 3925 IoIFP(io) = PerlIO_stdin();
adbc6bb1 3926 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
a5f75d66 3927 GvMULTI_on(tmpgv);
af8c498a 3928 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
79072805 3929
85e6fe83 3930 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
a5f75d66 3931 GvMULTI_on(tmpgv);
af8c498a 3932 io = GvIOp(tmpgv);
a04651f4 3933 IoTYPE(io) = IoTYPE_WRONLY;
af8c498a 3934 IoOFP(io) = IoIFP(io) = PerlIO_stdout();
4633a7c4 3935 setdefout(tmpgv);
adbc6bb1 3936 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
a5f75d66 3937 GvMULTI_on(tmpgv);
af8c498a 3938 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
79072805 3939
bf49b057
GS		 3940 PL_stderrgv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
3941 GvMULTI_on(PL_stderrgv);
3942 io = GvIOp(PL_stderrgv);
a04651f4 3943 IoTYPE(io) = IoTYPE_WRONLY;
af8c498a 3944 IoOFP(io) = IoIFP(io) = PerlIO_stderr();
adbc6bb1 3945 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
a5f75d66 3946 GvMULTI_on(tmpgv);
af8c498a 3947 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
79072805 3948
3280af22 3949 PL_statname = NEWSV(66,0); /* last filename we did stat on */
ab821d7f 3950
bf4acbe4
GS		 3951 if (PL_osname)
3952 Safefree(PL_osname);
3953 PL_osname = savepv(OSNAME);
79072805 3954}
33b78306 3955
a11ec5a9
RGS		 3956void
3957Perl_init_argv_symbols(pTHX_ register int argc, register char **argv)
33b78306 3958{
79072805 3959 char *s;
79072805 3960 argc--,argv++; /* skip name of script */
3280af22 3961 if (PL_doswitches) {
79072805
LW		 3962 for (; argc > 0 && **argv == '-'; argc--,argv++) {
3963 if (!argv[0][1])
3964 break;
379d538a 3965 if (argv[0][1] == '-' && !argv[0][2]) {
79072805
LW		 3966 argc--,argv++;
3967 break;
3968 }
155aba94 3969 if ((s = strchr(argv[0], '='))) {
79072805 3970 *s++ = '\0';
85e6fe83 3971 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
79072805
LW		 3972 }
3973 else
85e6fe83 3974 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
fe14fcc3 3975 }
79072805 3976 }
a11ec5a9
RGS		 3977 if ((PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV))) {
3978 GvMULTI_on(PL_argvgv);
3979 (void)gv_AVadd(PL_argvgv);
3980 av_clear(GvAVn(PL_argvgv));
3981 for (; argc > 0; argc--,argv++) {
3982 SV *sv = newSVpv(argv[0],0);
3983 av_push(GvAVn(PL_argvgv),sv);
ce81ff12
JH		 3984 if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) {
3985 if (PL_unicode & PERL_UNICODE_ARGV_FLAG)
3986 SvUTF8_on(sv);
3987 }
a05d7ebb
JH		 3988 if (PL_unicode & PERL_UNICODE_WIDESYSCALLS_FLAG) /* Sarathy? */
3989 (void)sv_utf8_decode(sv);
a11ec5a9
RGS		 3990 }
3991 }
3992}
3993
3994STATIC void
3995S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
3996{
3997 char *s;
3998 SV *sv;
3999 GV* tmpgv;
a11ec5a9 4000
3280af22
NIS		 4001 PL_toptarget = NEWSV(0,0);
4002 sv_upgrade(PL_toptarget, SVt_PVFM);
4003 sv_setpvn(PL_toptarget, "", 0);
4004 PL_bodytarget = NEWSV(0,0);
4005 sv_upgrade(PL_bodytarget, SVt_PVFM);
4006 sv_setpvn(PL_bodytarget, "", 0);
4007 PL_formtarget = PL_bodytarget;
79072805 4008
bbce6d69 4009 TAINT;
a11ec5a9
RGS		 4010
4011 init_argv_symbols(argc,argv);
4012
155aba94 4013 if ((tmpgv = gv_fetchpv("0",TRUE, SVt_PV))) {
bf4acbe4
GS		 4014#ifdef MACOS_TRADITIONAL
4015 /* $0 is not majick on a Mac */
4016 sv_setpv(GvSV(tmpgv),MacPerl_MPWFileName(PL_origfilename));
4017#else
3280af22 4018 sv_setpv(GvSV(tmpgv),PL_origfilename);
79072805 4019 magicname("0", "0", 1);
bf4acbe4 4020#endif
79072805 4021 }
155aba94 4022 if ((PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV))) {
79072805 4023 HV *hv;
3280af22
NIS		 4024 GvMULTI_on(PL_envgv);
4025 hv = GvHVn(PL_envgv);
14befaf4 4026 hv_magic(hv, Nullgv, PERL_MAGIC_env);
2f42fcb0 4027#ifndef PERL_MICRO
fa6a1c44 4028#ifdef USE_ENVIRON_ARRAY
4633a7c4
LW		 4029 /* Note that if the supplied env parameter is actually a copy
4030 of the global environ then it may now point to free'd memory
4031 if the environment has been modified since. To avoid this
4032 problem we treat env==NULL as meaning 'use the default'
4033 */
4034 if (!env)
4035 env = environ;
4efc5df6
GS		 4036 if (env != environ
4037# ifdef USE_ITHREADS
4038 && PL_curinterp == aTHX
4039# endif
4040 )
4041 {
79072805 4042 environ[0] = Nullch;
4efc5df6 4043 }
9b4eeda5
MB		 4044 if (env) {
4045 char** origenv = environ;
764df951 4046 for (; *env; env++) {
9b4eeda5 4047 if (!(s = strchr(*env,'=')) || s == *env)
79072805 4048 continue;
7da0e383 4049#if defined(MSDOS) && !defined(DJGPP)
61968511 4050 *s = '\0';
137443ea 4051 (void)strupr(*env);
61968511 4052 *s = '=';
137443ea 4053#endif
61968511 4054 sv = newSVpv(s+1, 0);
79072805 4055 (void)hv_store(hv, *env, s - *env, sv, 0);
61968511
GA		 4056 if (env != environ)
4057 mg_set(sv);
9b4eeda5
MB		 4058 if (origenv != environ) {
4059 /* realloc has shifted us */
4060 env = (env - origenv) + environ;
4061 origenv = environ;
4062 }
764df951 4063 }
9b4eeda5 4064 }
103a7189 4065#endif /* USE_ENVIRON_ARRAY */
2f42fcb0 4066#endif /* !PERL_MICRO */
79072805 4067 }
bbce6d69 4068 TAINT_NOT;
306196c3
MS		 4069 if ((tmpgv = gv_fetchpv("$",TRUE, SVt_PV))) {
4070 SvREADONLY_off(GvSV(tmpgv));
7766f137 4071 sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
306196c3
MS		 4072 SvREADONLY_on(GvSV(tmpgv));
4073 }
4d76a344
RGS		 4074#ifdef THREADS_HAVE_PIDS
4075 PL_ppid = (IV)getppid();
4076#endif
2710853f
MJD		 4077
4078 /* touch @F array to prevent spurious warnings 20020415 MJD */
4079 if (PL_minus_a) {
4080 (void) get_av("main::F", TRUE | GV_ADDMULTI);
4081 }
4082 /* touch @- and @+ arrays to prevent spurious warnings 20020415 MJD */
4083 (void) get_av("main::-", TRUE | GV_ADDMULTI);
4084 (void) get_av("main::+", TRUE | GV_ADDMULTI);
33b78306 4085}
34de22dd 4086
76e3520e 4087STATIC void
cea2e8a9 4088S_init_perllib(pTHX)
34de22dd 4089{
85e6fe83 4090 char *s;
3280af22 4091 if (!PL_tainting) {
552a7a9b 4092#ifndef VMS
76e3520e 4093 s = PerlEnv_getenv("PERL5LIB");
85e6fe83 4094 if (s)
88fe16b2 4095 incpush(s, TRUE, TRUE, TRUE, FALSE);
85e6fe83 4096 else
88fe16b2 4097 incpush(PerlEnv_getenv("PERLLIB"), FALSE, FALSE, TRUE, FALSE);
552a7a9b 4098#else /* VMS */
4099 /* Treat PERL5?LIB as a possible search list logical name -- the
4100 * "natural" VMS idiom for a Unix path string. We allow each
4101 * element to be a set of |-separated directories for compatibility.
4102 */
4103 char buf[256];
4104 int idx = 0;
4105 if (my_trnlnm("PERL5LIB",buf,0))
88fe16b2 4106 do { incpush(buf,TRUE,TRUE,TRUE,FALSE); } while (my_trnlnm("PERL5LIB",buf,++idx));
552a7a9b 4107 else
88fe16b2 4108 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE,FALSE,TRUE,FALSE);
552a7a9b 4109#endif /* VMS */
85e6fe83 4110 }
34de22dd 4111
c90c0ff4 4112/* Use the ~-expanded versions of APPLLIB (undocumented),
65f19062 4113 ARCHLIB PRIVLIB SITEARCH SITELIB VENDORARCH and VENDORLIB
df5cef82 4114*/
4633a7c4 4115#ifdef APPLLIB_EXP
88fe16b2 4116 incpush(APPLLIB_EXP, TRUE, TRUE, TRUE, TRUE);
16d20bd9 4117#endif
4633a7c4 4118
fed7345c 4119#ifdef ARCHLIB_EXP
88fe16b2 4120 incpush(ARCHLIB_EXP, FALSE, FALSE, TRUE, TRUE);
a0d0e21e 4121#endif
bf4acbe4
GS		 4122#ifdef MACOS_TRADITIONAL
4123 {
c623ac67 4124 Stat_t tmpstatbuf;
bf4acbe4
GS		 4125 SV * privdir = NEWSV(55, 0);
4126 char * macperl = PerlEnv_getenv("MACPERL");
4127
4128 if (!macperl)
4129 macperl = "";
4130
4131 Perl_sv_setpvf(aTHX_ privdir, "%slib:", macperl);
4132 if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode))
88fe16b2 4133 incpush(SvPVX(privdir), TRUE, FALSE, TRUE, FALSE);
bf4acbe4
GS		 4134 Perl_sv_setpvf(aTHX_ privdir, "%ssite_perl:", macperl);
4135 if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode))
88fe16b2 4136 incpush(SvPVX(privdir), TRUE, FALSE, TRUE, FALSE);
ac27b0f5 4137
bf4acbe4
GS		 4138 SvREFCNT_dec(privdir);
4139 }
4140 if (!PL_tainting)
88fe16b2 4141 incpush(":", FALSE, FALSE, TRUE, FALSE);
bf4acbe4 4142#else
fed7345c 4143#ifndef PRIVLIB_EXP
65f19062 4144# define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
34de22dd 4145#endif
ac27b0f5 4146#if defined(WIN32)
88fe16b2 4147 incpush(PRIVLIB_EXP, TRUE, FALSE, TRUE, TRUE);
00dc2f4f 4148#else
88fe16b2 4149 incpush(PRIVLIB_EXP, FALSE, FALSE, TRUE, TRUE);
00dc2f4f 4150#endif
4633a7c4 4151
65f19062 4152#ifdef SITEARCH_EXP
3b290362
GS		 4153 /* sitearch is always relative to sitelib on Windows for
4154 * DLL-based path intuition to work correctly */
4155# if !defined(WIN32)
88fe16b2 4156 incpush(SITEARCH_EXP, FALSE, FALSE, TRUE, TRUE);
65f19062
GS		 4157# endif
4158#endif
4159
4633a7c4 4160#ifdef SITELIB_EXP
65f19062 4161# if defined(WIN32)
574c798a 4162 /* this picks up sitearch as well */
88fe16b2 4163 incpush(SITELIB_EXP, TRUE, FALSE, TRUE, TRUE);
65f19062 4164# else
88fe16b2 4165 incpush(SITELIB_EXP, FALSE, FALSE, TRUE, TRUE);
65f19062
GS		 4166# endif
4167#endif
189d1e8d 4168
65f19062 4169#ifdef SITELIB_STEM /* Search for version-specific dirs below here */
88fe16b2 4170 incpush(SITELIB_STEM, FALSE, TRUE, TRUE, TRUE);
81c6dfba 4171#endif
65f19062
GS		 4172
4173#ifdef PERL_VENDORARCH_EXP
4ea817c6 4174 /* vendorarch is always relative to vendorlib on Windows for
3b290362
GS		 4175 * DLL-based path intuition to work correctly */
4176# if !defined(WIN32)
88fe16b2 4177 incpush(PERL_VENDORARCH_EXP, FALSE, FALSE, TRUE, TRUE);
65f19062 4178# endif
4b03c463 4179#endif
65f19062
GS		 4180
4181#ifdef PERL_VENDORLIB_EXP
4182# if defined(WIN32)
88fe16b2 4183 incpush(PERL_VENDORLIB_EXP, TRUE, FALSE, TRUE, TRUE); /* this picks up vendorarch as well */
65f19062 4184# else
88fe16b2 4185 incpush(PERL_VENDORLIB_EXP, FALSE, FALSE, TRUE, TRUE);
65f19062 4186# endif
a3635516 4187#endif
65f19062
GS		 4188
4189#ifdef PERL_VENDORLIB_STEM /* Search for version-specific dirs below here */
88fe16b2 4190 incpush(PERL_VENDORLIB_STEM, FALSE, TRUE, TRUE, TRUE);
00dc2f4f 4191#endif
65f19062 4192
3b777bb4 4193#ifdef PERL_OTHERLIBDIRS
88fe16b2 4194 incpush(PERL_OTHERLIBDIRS, TRUE, TRUE, TRUE, TRUE);
3b777bb4
GS		 4195#endif
4196
3280af22 4197 if (!PL_tainting)
88fe16b2 4198 incpush(".", FALSE, FALSE, TRUE, FALSE);
bf4acbe4 4199#endif /* MACOS_TRADITIONAL */
774d564b 4200}
4201
ed79a026 4202#if defined(DOSISH) || defined(EPOC)
774d564b 4203# define PERLLIB_SEP ';'
4204#else
4205# if defined(VMS)
4206# define PERLLIB_SEP '|'
4207# else
bf4acbe4
GS		 4208# if defined(MACOS_TRADITIONAL)
4209# define PERLLIB_SEP ','
4210# else
4211# define PERLLIB_SEP ':'
4212# endif
774d564b 4213# endif
4214#endif
4215#ifndef PERLLIB_MANGLE
4216# define PERLLIB_MANGLE(s,n) (s)
ac27b0f5 4217#endif
774d564b 4218
ad17a1ae
NC		 4219/* Push a directory onto @INC if it exists.
4220 Generate a new SV if we do this, to save needing to copy the SV we push
4221 onto @INC */
4222STATIC SV *
4223S_incpush_if_exists(pTHX_ SV *dir)
4224{
4225 Stat_t tmpstatbuf;
4226 if (PerlLIO_stat(SvPVX(dir), &tmpstatbuf) >= 0 &&
4227 S_ISDIR(tmpstatbuf.st_mode)) {
4228 av_push(GvAVn(PL_incgv), dir);
4229 dir = NEWSV(0,0);
4230 }
4231 return dir;
4232}
4233
76e3520e 4234STATIC void
88fe16b2
NC		 4235S_incpush(pTHX_ char *p, int addsubdirs, int addoldvers, int usesep,
4236 int canrelocate)
774d564b 4237{
4238 SV *subdir = Nullsv;
774d564b 4239
3b290362 4240 if (!p || !*p)
774d564b 4241 return;
4242
9c8a64f0 4243 if (addsubdirs || addoldvers) {
ad17a1ae 4244 subdir = NEWSV(0,0);
774d564b 4245 }
4246
4247 /* Break at all separators */
4248 while (p && *p) {
8c52afec 4249 SV *libdir = NEWSV(55,0);
774d564b 4250 char *s;
4251
4252 /* skip any consecutive separators */
574c798a
SR		 4253 if (usesep) {
4254 while ( *p == PERLLIB_SEP ) {
4255 /* Uncomment the next line for PATH semantics */
4256 /* av_push(GvAVn(PL_incgv), newSVpvn(".", 1)); */
4257 p++;
4258 }
774d564b 4259 }
4260
574c798a 4261 if ( usesep && (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
774d564b 4262 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
4263 (STRLEN)(s - p));
4264 p = s + 1;
4265 }
4266 else {
4267 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
4268 p = Nullch; /* break out */
4269 }
bf4acbe4 4270#ifdef MACOS_TRADITIONAL
e69a2255
JH		 4271 if (!strchr(SvPVX(libdir), ':')) {
4272 char buf[256];
4273
4274 sv_setpv(libdir, MacPerl_CanonDir(SvPVX(libdir), buf, 0));
4275 }
bf4acbe4
GS		 4276 if (SvPVX(libdir)[SvCUR(libdir)-1] != ':')
4277 sv_catpv(libdir, ":");
4278#endif
774d564b 4279
88fe16b2
NC		 4280#ifdef PERL_RELOCATABLE_INC
4281 /*
4282 * Relocatable include entries are marked with a leading .../
4283 *
4284 * The algorithm is
4285 * 0: Remove that leading ".../"
4286 * 1: Remove trailing executable name (anything after the last '/')
4287 * from the perl path to give a perl prefix
4288 * Then
4289 * While the @INC element starts "../" and the prefix ends with a real
4290 * directory (ie not . or ..) chop that real directory off the prefix
4291 * and the leading "../" from the @INC element. ie a logical "../"
4292 * cleanup
4293 * Finally concatenate the prefix and the remainder of the @INC element
4294 * The intent is that /usr/local/bin/perl and .../../lib/perl5
4295 * generates /usr/local/lib/perl5
4296 */
4297 {
4298 char *libpath = SvPVX(libdir);
4299 STRLEN libpath_len = SvCUR(libdir);
4300 if (libpath_len >= 4 && memEQ (libpath, ".../", 4)) {
4301 /* Game on! */
4302 SV *caret_X = get_sv("\030", 0);
4303 /* Going to use the SV just as a scratch buffer holding a C
4304 string: */
4305 SV *prefix_sv;
4306 char *prefix;
4307 char *lastslash;
4308
4309 /* $^X is *the* source of taint if tainting is on, hence
4310 SvPOK() won't be true. */
4311 assert(caret_X);
4312 assert(SvPOKp(caret_X));
4313 prefix_sv = newSVpvn(SvPVX(caret_X), SvCUR(caret_X));
4314 /* Firstly take off the leading .../
4315 If all else fail we'll do the paths relative to the current
4316 directory. */
4317 sv_chop(libdir, libpath + 4);
4318 /* Don't use SvPV as we're intentionally bypassing taining,
4319 mortal copies that the mg_get of tainting creates, and
4320 corruption that seems to come via the save stack.
4321 I guess that the save stack isn't correctly set up yet. */
4322 libpath = SvPVX(libdir);
4323 libpath_len = SvCUR(libdir);
4324
4325 /* This would work more efficiently with memrchr, but as it's
4326 only a GNU extension we'd need to probe for it and
4327 implement our own. Not hard, but maybe not worth it? */
4328
4329 prefix = SvPVX(prefix_sv);
4330 lastslash = strrchr(prefix, '/');
4331
4332 /* First time in with the *lastslash = '\0' we just wipe off
4333 the trailing /perl from (say) /usr/foo/bin/perl
4334 */
4335 if (lastslash) {
4336 SV *tempsv;
4337 while ((*lastslash = '\0'), /* Do that, come what may. */
4338 (libpath_len >= 3 && memEQ(libpath, "../", 3)
4339 && (lastslash = strrchr(prefix, '/')))) {
4340 if (lastslash[1] == '\0'
4341 || (lastslash[1] == '.'
4342 && (lastslash[2] == '/' /* ends "/." */
4343 || (lastslash[2] == '/'
4344 && lastslash[3] == '/' /* or "/.." */
4345 )))) {
4346 /* Prefix ends "/" or "/." or "/..", any of which
4347 are fishy, so don't do any more logical cleanup.
4348 */
4349 break;
4350 }
4351 /* Remove leading "../" from path */
4352 libpath += 3;
4353 libpath_len -= 3;
4354 /* Next iteration round the loop removes the last
4355 directory name from prefix by writing a '\0' in
4356 the while clause. */
4357 }
4358 /* prefix has been terminated with a '\0' to the correct
4359 length. libpath points somewhere into the libdir SV.
4360 We need to join the 2 with '/' and drop the result into
4361 libdir. */
4362 tempsv = Perl_newSVpvf(aTHX_ "%s/%s", prefix, libpath);
4363 SvREFCNT_dec(libdir);
4364 /* And this is the new libdir. */
4365 libdir = tempsv;
4366 if (PL_tainting &&
4367 (PL_uid != PL_euid || PL_gid != PL_egid)) {
4368 /* Need to taint reloccated paths if running set ID */
4369 SvTAINTED_on(libdir);
4370 }
4371 }
4372 SvREFCNT_dec(prefix_sv);
4373 }
4374 }
4375#endif
774d564b 4376 /*
4377 * BEFORE pushing libdir onto @INC we may first push version- and
4378 * archname-specific sub-directories.
4379 */
9c8a64f0 4380 if (addsubdirs || addoldvers) {
29d82f8d 4381#ifdef PERL_INC_VERSION_LIST
8353b874
GS		 4382 /* Configure terminates PERL_INC_VERSION_LIST with a NULL */
4383 const char *incverlist[] = { PERL_INC_VERSION_LIST };
29d82f8d
GS		 4384 const char **incver;
4385#endif
aa689395 4386#ifdef VMS
4387 char *unix;
4388 STRLEN len;
774d564b 4389
2d8e6c8d 4390 if ((unix = tounixspec_ts(SvPV(libdir,len),Nullch)) != Nullch) {
aa689395 4391 len = strlen(unix);
4392 while (unix[len-1] == '/') len--; /* Cosmetic */
4393 sv_usepvn(libdir,unix,len);
4394 }
4395 else
bf49b057 4396 PerlIO_printf(Perl_error_log,
aa689395 4397 "Failed to unixify @INC element \"%s\"\n",
2d8e6c8d 4398 SvPV(libdir,len));
aa689395 4399#endif
9c8a64f0 4400 if (addsubdirs) {
bf4acbe4
GS		 4401#ifdef MACOS_TRADITIONAL
4402#define PERL_AV_SUFFIX_FMT ""
084592ab
CN		 4403#define PERL_ARCH_FMT "%s:"
4404#define PERL_ARCH_FMT_PATH PERL_FS_VER_FMT PERL_AV_SUFFIX_FMT
bf4acbe4
GS		 4405#else
4406#define PERL_AV_SUFFIX_FMT "/"
4407#define PERL_ARCH_FMT "/%s"
084592ab 4408#define PERL_ARCH_FMT_PATH PERL_AV_SUFFIX_FMT PERL_FS_VER_FMT
bf4acbe4 4409#endif
9c8a64f0 4410 /* .../version/archname if -d .../version/archname */
084592ab 4411 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH PERL_ARCH_FMT,
9c8a64f0
GS		 4412 libdir,
4413 (int)PERL_REVISION, (int)PERL_VERSION,
4414 (int)PERL_SUBVERSION, ARCHNAME);
ad17a1ae 4415 subdir = S_incpush_if_exists(aTHX_ subdir);
4b03c463 4416
9c8a64f0 4417 /* .../version if -d .../version */
084592ab 4418 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH, libdir,
9c8a64f0
GS		 4419 (int)PERL_REVISION, (int)PERL_VERSION,
4420 (int)PERL_SUBVERSION);
ad17a1ae 4421 subdir = S_incpush_if_exists(aTHX_ subdir);
9c8a64f0
GS		 4422
4423 /* .../archname if -d .../archname */
bf4acbe4 4424 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, libdir, ARCHNAME);
ad17a1ae
NC		 4425 subdir = S_incpush_if_exists(aTHX_ subdir);
4426
29d82f8d 4427 }
9c8a64f0 4428
9c8a64f0 4429#ifdef PERL_INC_VERSION_LIST
ccc2aad8 4430 if (addoldvers) {
9c8a64f0
GS		 4431 for (incver = incverlist; *incver; incver++) {
4432 /* .../xxx if -d .../xxx */
bf4acbe4 4433 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, libdir, *incver);
ad17a1ae 4434 subdir = S_incpush_if_exists(aTHX_ subdir);
9c8a64f0
GS		 4435 }
4436 }
29d82f8d 4437#endif
774d564b 4438 }
4439
4440 /* finally push this lib directory on the end of @INC */
3280af22 4441 av_push(GvAVn(PL_incgv), libdir);
774d564b 4442 }
ad17a1ae 4443 if (subdir) {
ef97f5b3 4444 assert (SvREFCNT(subdir) == 1);
ad17a1ae
NC		 4445 SvREFCNT_dec(subdir);
4446 }
34de22dd 4447}
93a17b20 4448
4d1ff10f 4449#ifdef USE_5005THREADS
76e3520e 4450STATIC struct perl_thread *
cea2e8a9 4451S_init_main_thread(pTHX)
199100c8 4452{
c5be433b 4453#if !defined(PERL_IMPLICIT_CONTEXT)
52e1cb5e 4454 struct perl_thread *thr;
cea2e8a9 4455#endif
199100c8
MB		 4456 XPV *xpv;
4457
52e1cb5e 4458 Newz(53, thr, 1, struct perl_thread);
533c011a 4459 PL_curcop = &PL_compiling;
c5be433b 4460 thr->interp = PERL_GET_INTERP;
199100c8 4461 thr->cvcache = newHV();
54b9620d 4462 thr->threadsv = newAV();
940cb80d 4463 /* thr->threadsvp is set when find_threadsv is called */
199100c8
MB		 4464 thr->specific = newAV();
4465 thr->flags = THRf_R_JOINABLE;
4466 MUTEX_INIT(&thr->mutex);
4467 /* Handcraft thrsv similarly to mess_sv */
533c011a 4468 New(53, PL_thrsv, 1, SV);
199100c8 4469 Newz(53, xpv, 1, XPV);
533c011a
NIS		 4470 SvFLAGS(PL_thrsv) = SVt_PV;
4471 SvANY(PL_thrsv) = (void*)xpv;
4472 SvREFCNT(PL_thrsv) = 1 << 30; /* practically infinite */
4473 SvPVX(PL_thrsv) = (char*)thr;
4474 SvCUR_set(PL_thrsv, sizeof(thr));
4475 SvLEN_set(PL_thrsv, sizeof(thr));
4476 *SvEND(PL_thrsv) = '\0'; /* in the trailing_nul field */
4477 thr->oursv = PL_thrsv;
4478 PL_chopset = " \n-";
3967c732 4479 PL_dumpindent = 4;
533c011a
NIS		 4480
4481 MUTEX_LOCK(&PL_threads_mutex);
4482 PL_nthreads++;
199100c8
MB		 4483 thr->tid = 0;
4484 thr->next = thr;
4485 thr->prev = thr;
8dcd6f7b 4486 thr->thr_done = 0;
533c011a 4487 MUTEX_UNLOCK(&PL_threads_mutex);
199100c8 4488
4b026b9e 4489#ifdef HAVE_THREAD_INTERN
4f63d024 4490 Perl_init_thread_intern(thr);
235db74f
GS		 4491#endif
4492
4493#ifdef SET_THREAD_SELF
4494 SET_THREAD_SELF(thr);
199100c8
MB		 4495#else
4496 thr->self = pthread_self();
235db74f 4497#endif /* SET_THREAD_SELF */
06d86050 4498 PERL_SET_THX(thr);
199100c8
MB		 4499
4500 /*
411caa50
JH		 4501 * These must come after the thread self setting
4502 * because sv_setpvn does SvTAINT and the taint
4503 * fields thread selfness being set.
199100c8 4504 */
533c011a
NIS		 4505 PL_toptarget = NEWSV(0,0);
4506 sv_upgrade(PL_toptarget, SVt_PVFM);
4507 sv_setpvn(PL_toptarget, "", 0);
4508 PL_bodytarget = NEWSV(0,0);
4509 sv_upgrade(PL_bodytarget, SVt_PVFM);
4510 sv_setpvn(PL_bodytarget, "", 0);
4511 PL_formtarget = PL_bodytarget;
79cb57f6 4512 thr->errsv = newSVpvn("", 0);
78857c3c 4513 (void) find_threadsv("@"); /* Ensure $@ is initialised early */
5c0ca799 4514
533c011a 4515 PL_maxscream = -1;
a2efc822 4516 PL_peepp = MEMBER_TO_FPTR(Perl_peep);
0b94c7bb
GS		 4517 PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp);
4518 PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags);
4519 PL_regint_start = MEMBER_TO_FPTR(Perl_re_intuit_start);
4520 PL_regint_string = MEMBER_TO_FPTR(Perl_re_intuit_string);
4521 PL_regfree = MEMBER_TO_FPTR(Perl_pregfree);
533c011a
NIS		 4522 PL_regindent = 0;
4523 PL_reginterp_cnt = 0;
5c0ca799 4524
199100c8
MB		 4525 return thr;
4526}
4d1ff10f 4527#endif /* USE_5005THREADS */
199100c8 4528
93a17b20 4529void
864dbfa3 4530Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
93a17b20 4531{
971a9dd3 4532 SV *atsv;
57843af0 4533 line_t oldline = CopLINE(PL_curcop);
312caa8e 4534 CV *cv;
22921e25 4535 STRLEN len;
6224f72b 4536 int ret;
db36c5a1 4537 dJMPENV;
93a17b20 4538
76e3520e 4539 while (AvFILL(paramList) >= 0) {
312caa8e 4540 cv = (CV*)av_shift(paramList);
ece599bd
RGS		 4541 if (PL_savebegin) {
4542 if (paramList == PL_beginav) {
059a8bb7 4543 /* save PL_beginav for compiler */
ece599bd
RGS		 4544 if (! PL_beginav_save)
4545 PL_beginav_save = newAV();
4546 av_push(PL_beginav_save, (SV*)cv);
4547 }
4548 else if (paramList == PL_checkav) {
4549 /* save PL_checkav for compiler */
4550 if (! PL_checkav_save)
4551 PL_checkav_save = newAV();
4552 av_push(PL_checkav_save, (SV*)cv);
4553 }
059a8bb7
JH		 4554 } else {
4555 SAVEFREESV(cv);
4556 }
14dd3ad8 4557 JMPENV_PUSH(ret);
6224f72b 4558 switch (ret) {
312caa8e 4559 case 0:
14dd3ad8 4560 call_list_body(cv);
971a9dd3 4561 atsv = ERRSV;
312caa8e
CS		 4562 (void)SvPV(atsv, len);
4563 if (len) {
4564 PL_curcop = &PL_compiling;
57843af0 4565 CopLINE_set(PL_curcop, oldline);
312caa8e
CS		 4566 if (paramList == PL_beginav)
4567 sv_catpv(atsv, "BEGIN failed--compilation aborted");
4568 else
4f25aa18
GS		 4569 Perl_sv_catpvf(aTHX_ atsv,
4570 "%s failed--call queue aborted",
7d30b5c4 4571 paramList == PL_checkav ? "CHECK"
4f25aa18
GS		 4572 : paramList == PL_initav ? "INIT"
4573 : "END");
312caa8e
CS		 4574 while (PL_scopestack_ix > oldscope)
4575 LEAVE;
14dd3ad8 4576 JMPENV_POP;
35c1215d 4577 Perl_croak(aTHX_ "%"SVf"", atsv);
a0d0e21e 4578 }
85e6fe83 4579 break;
6224f72b 4580 case 1:
f86702cc 4581 STATUS_ALL_FAILURE;
85e6fe83 4582 /* FALL THROUGH */
6224f72b 4583 case 2:
85e6fe83 4584 /* my_exit() was called */
3280af22 4585 while (PL_scopestack_ix > oldscope)
2ae324a7 4586 LEAVE;
84902520 4587 FREETMPS;
3280af22 4588 PL_curstash = PL_defstash;
3280af22 4589 PL_curcop = &PL_compiling;
57843af0 4590 CopLINE_set(PL_curcop, oldline);
14dd3ad8 4591 JMPENV_POP;
cc3604b1 4592 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED)) {
3280af22 4593 if (paramList == PL_beginav)
cea2e8a9 4594 Perl_croak(aTHX_ "BEGIN failed--compilation aborted");
85e6fe83 4595 else
4f25aa18 4596 Perl_croak(aTHX_ "%s failed--call queue aborted",
7d30b5c4 4597 paramList == PL_checkav ? "CHECK"
4f25aa18
GS		 4598 : paramList == PL_initav ? "INIT"
4599 : "END");
85e6fe83 4600 }
f86702cc 4601 my_exit_jump();
85e6fe83 4602 /* NOTREACHED */
6224f72b 4603 case 3:
312caa8e
CS		 4604 if (PL_restartop) {
4605 PL_curcop = &PL_compiling;
57843af0 4606 CopLINE_set(PL_curcop, oldline);
312caa8e 4607 JMPENV_JUMP(3);
85e6fe83 4608 }
bf49b057 4609 PerlIO_printf(Perl_error_log, "panic: restartop\n");
312caa8e
CS		 4610 FREETMPS;
4611 break;
8990e307 4612 }
14dd3ad8 4613 JMPENV_POP;
93a17b20 4614 }
93a17b20 4615}
93a17b20 4616
14dd3ad8
GS		 4617STATIC void *
4618S_call_list_body(pTHX_ CV *cv)
4619{
312caa8e 4620 PUSHMARK(PL_stack_sp);
864dbfa3 4621 call_sv((SV*)cv, G_EVAL|G_DISCARD);
312caa8e
CS		 4622 return NULL;
4623}
4624
f86702cc 4625void
864dbfa3 4626Perl_my_exit(pTHX_ U32 status)
f86702cc 4627{
8b73bbec 4628 DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
a863c7d1 4629 thr, (unsigned long) status));
f86702cc 4630 switch (status) {
4631 case 0:
4632 STATUS_ALL_SUCCESS;
4633 break;
4634 case 1:
4635 STATUS_ALL_FAILURE;
4636 break;
4637 default:
4638 STATUS_NATIVE_SET(status);
4639 break;
4640 }
4641 my_exit_jump();
4642}
4643
4644void
864dbfa3 4645Perl_my_failure_exit(pTHX)
f86702cc 4646{
4647#ifdef VMS
4648 if (vaxc$errno & 1) {
4fdae800 4649 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
4650 STATUS_NATIVE_SET(44);
f86702cc 4651 }
4652 else {
69232efa 4653 if (!vaxc$errno) /* unlikely */
4fdae800 4654 STATUS_NATIVE_SET(44);
f86702cc 4655 else
4fdae800 4656 STATUS_NATIVE_SET(vaxc$errno);
f86702cc 4657 }
4658#else
9b599b2a 4659 int exitstatus;
f86702cc 4660 if (errno & 255)
4661 STATUS_POSIX_SET(errno);
9b599b2a 4662 else {
ac27b0f5 4663 exitstatus = STATUS_POSIX >> 8;
9b599b2a
GS		 4664 if (exitstatus & 255)
4665 STATUS_POSIX_SET(exitstatus);
4666 else
4667 STATUS_POSIX_SET(255);
4668 }
f86702cc 4669#endif
4670 my_exit_jump();
93a17b20
LW		 4671}
4672
76e3520e 4673STATIC void
cea2e8a9 4674S_my_exit_jump(pTHX)
f86702cc 4675{
c09156bb 4676 register PERL_CONTEXT *cx;
f86702cc 4677 I32 gimme;
4678 SV **newsp;
4679
3280af22
NIS		 4680 if (PL_e_script) {
4681 SvREFCNT_dec(PL_e_script);
4682 PL_e_script = Nullsv;
f86702cc 4683 }
4684
3280af22 4685 POPSTACK_TO(PL_mainstack);
f86702cc 4686 if (cxstack_ix >= 0) {
4687 if (cxstack_ix > 0)
4688 dounwind(0);
3280af22 4689 POPBLOCK(cx,PL_curpm);
f86702cc 4690 LEAVE;
4691 }
ff0cee69 4692
6224f72b 4693 JMPENV_JUMP(2);
f86702cc 4694}
873ef191 4695
0cb96387 4696static I32
acfe0abc 4697read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen)
873ef191
GS		 4698{
4699 char *p, *nl;
3280af22 4700 p = SvPVX(PL_e_script);
873ef191 4701 nl = strchr(p, '\n');
3280af22 4702 nl = (nl) ? nl+1 : SvEND(PL_e_script);
7dfe3f66 4703 if (nl-p == 0) {
0cb96387 4704 filter_del(read_e_script);
873ef191 4705 return 0;
7dfe3f66 4706 }
873ef191 4707 sv_catpvn(buf_sv, p, nl-p);
3280af22 4708 sv_chop(PL_e_script, nl);
873ef191
GS		 4709 return 1;
4710}
Unnamed repository; edit this file 'description' to name the repository.