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