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