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
Fix copy & paste bugs in mX?PUSH macro tests.
[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
1d76a5c3 2054 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
4633a7c4 2055 PUSHEVAL(cx, 0, 0);
533c011a 2056 PL_eval_root = PL_op; /* Only needed so that goto works right. */
ac27b0f5 2057
faef0170 2058 PL_in_eval = EVAL_INEVAL;
4633a7c4 2059 if (flags & G_KEEPERR)
faef0170 2060 PL_in_eval |= EVAL_KEEPERR;
4633a7c4 2061 else
38a03e6e 2062 sv_setpv(ERRSV,"");
4633a7c4 2063 }
3280af22 2064 PL_markstack_ptr++;
a0d0e21e 2065
14dd3ad8
GS		 2066#ifdef PERL_FLEXIBLE_EXCEPTIONS
2067 redo_body:
2068 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_body),
db36c5a1 2069 (OP*)&myop, FALSE);
14dd3ad8
GS		 2070#else
2071 JMPENV_PUSH(ret);
2072#endif
6224f72b
GS		 2073 switch (ret) {
2074 case 0:
14dd3ad8
GS		 2075#ifndef PERL_FLEXIBLE_EXCEPTIONS
2076 redo_body:
2077 call_body((OP*)&myop, FALSE);
2078#endif
312caa8e
CS		 2079 retval = PL_stack_sp - (PL_stack_base + oldmark);
2080 if (!(flags & G_KEEPERR))
2081 sv_setpv(ERRSV,"");
a0d0e21e 2082 break;
6224f72b 2083 case 1:
f86702cc 2084 STATUS_ALL_FAILURE;
a0d0e21e 2085 /* FALL THROUGH */
6224f72b 2086 case 2:
a0d0e21e 2087 /* my_exit() was called */
3280af22 2088 PL_curstash = PL_defstash;
a0d0e21e 2089 FREETMPS;
14dd3ad8 2090 JMPENV_POP;
cc3604b1 2091 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
cea2e8a9 2092 Perl_croak(aTHX_ "Callback called exit");
f86702cc 2093 my_exit_jump();
a0d0e21e 2094 /* NOTREACHED */
6224f72b 2095 case 3:
3280af22 2096 if (PL_restartop) {
533c011a 2097 PL_op = PL_restartop;
3280af22 2098 PL_restartop = 0;
312caa8e 2099 goto redo_body;
a0d0e21e 2100 }
3280af22 2101 PL_stack_sp = PL_stack_base + oldmark;
a0d0e21e
LW		 2102 if (flags & G_ARRAY)
2103 retval = 0;
2104 else {
2105 retval = 1;
3280af22 2106 *++PL_stack_sp = &PL_sv_undef;
a0d0e21e 2107 }
312caa8e 2108 break;
a0d0e21e 2109 }
a0d0e21e 2110
3280af22 2111 if (PL_scopestack_ix > oldscope) {
a0a2876f
LW		 2112 SV **newsp;
2113 PMOP *newpm;
2114 I32 gimme;
c09156bb 2115 register PERL_CONTEXT *cx;
a0a2876f
LW		 2116 I32 optype;
2117
2118 POPBLOCK(cx,newpm);
2119 POPEVAL(cx);
3280af22 2120 PL_curpm = newpm;
a0a2876f 2121 LEAVE;
a0d0e21e 2122 }
14dd3ad8 2123 JMPENV_POP;
a0d0e21e 2124 }
1e422769 2125
a0d0e21e 2126 if (flags & G_DISCARD) {
3280af22 2127 PL_stack_sp = PL_stack_base + oldmark;
a0d0e21e
LW		 2128 retval = 0;
2129 FREETMPS;
2130 LEAVE;
2131 }
533c011a 2132 PL_op = oldop;
a0d0e21e
LW		 2133 return retval;
2134}
2135
14dd3ad8 2136#ifdef PERL_FLEXIBLE_EXCEPTIONS
312caa8e 2137STATIC void *
14dd3ad8 2138S_vcall_body(pTHX_ va_list args)
312caa8e
CS		 2139{
2140 OP *myop = va_arg(args, OP*);
2141 int is_eval = va_arg(args, int);
2142
14dd3ad8 2143 call_body(myop, is_eval);
312caa8e
CS		 2144 return NULL;
2145}
14dd3ad8 2146#endif
312caa8e
CS		 2147
2148STATIC void
14dd3ad8 2149S_call_body(pTHX_ OP *myop, int is_eval)
312caa8e 2150{
312caa8e
CS		 2151 if (PL_op == myop) {
2152 if (is_eval)
f807eda9 2153 PL_op = Perl_pp_entereval(aTHX); /* this doesn't do a POPMARK */
312caa8e 2154 else
f807eda9 2155 PL_op = Perl_pp_entersub(aTHX); /* this does */
312caa8e
CS		 2156 }
2157 if (PL_op)
cea2e8a9 2158 CALLRUNOPS(aTHX);
312caa8e
CS		 2159}
2160
6e72f9df 2161/* Eval a string. The G_EVAL flag is always assumed. */
8990e307 2162
954c1994
GS		 2163/*
2164=for apidoc p||eval_sv
2165
2166Tells Perl to C<eval> the string in the SV.
2167
2168=cut
2169*/
2170
a0d0e21e 2171I32
864dbfa3 2172Perl_eval_sv(pTHX_ SV *sv, I32 flags)
ac27b0f5 2173
8ac85365 2174 /* See G_* flags in cop.h */
a0d0e21e 2175{
924508f0 2176 dSP;
a0d0e21e 2177 UNOP myop; /* fake syntax tree node */
8fa7f367 2178 volatile I32 oldmark = SP - PL_stack_base;
13689cfe 2179 volatile I32 retval = 0;
4633a7c4 2180 I32 oldscope;
6224f72b 2181 int ret;
533c011a 2182 OP* oldop = PL_op;
db36c5a1 2183 dJMPENV;
84902520 2184
4633a7c4
LW		 2185 if (flags & G_DISCARD) {
2186 ENTER;
2187 SAVETMPS;
2188 }
2189
462e5cf6 2190 SAVEOP();
533c011a
NIS		 2191 PL_op = (OP*)&myop;
2192 Zero(PL_op, 1, UNOP);
3280af22
NIS		 2193 EXTEND(PL_stack_sp, 1);
2194 *++PL_stack_sp = sv;
2195 oldscope = PL_scopestack_ix;
79072805 2196
4633a7c4
LW		 2197 if (!(flags & G_NOARGS))
2198 myop.op_flags = OPf_STACKED;
79072805 2199 myop.op_next = Nullop;
6e72f9df 2200 myop.op_type = OP_ENTEREVAL;
54310121 2201 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
2202 (flags & G_ARRAY) ? OPf_WANT_LIST :
2203 OPf_WANT_SCALAR);
6e72f9df 2204 if (flags & G_KEEPERR)
2205 myop.op_flags |= OPf_SPECIAL;
4633a7c4 2206
14dd3ad8 2207#ifdef PERL_FLEXIBLE_EXCEPTIONS
312caa8e 2208 redo_body:
14dd3ad8 2209 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_body),
db36c5a1 2210 (OP*)&myop, TRUE);
14dd3ad8
GS		 2211#else
2212 JMPENV_PUSH(ret);
2213#endif
6224f72b
GS		 2214 switch (ret) {
2215 case 0:
14dd3ad8
GS		 2216#ifndef PERL_FLEXIBLE_EXCEPTIONS
2217 redo_body:
2218 call_body((OP*)&myop,TRUE);
2219#endif
312caa8e
CS		 2220 retval = PL_stack_sp - (PL_stack_base + oldmark);
2221 if (!(flags & G_KEEPERR))
2222 sv_setpv(ERRSV,"");
4633a7c4 2223 break;
6224f72b 2224 case 1:
f86702cc 2225 STATUS_ALL_FAILURE;
4633a7c4 2226 /* FALL THROUGH */
6224f72b 2227 case 2:
4633a7c4 2228 /* my_exit() was called */
3280af22 2229 PL_curstash = PL_defstash;
4633a7c4 2230 FREETMPS;
14dd3ad8 2231 JMPENV_POP;
cc3604b1 2232 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
cea2e8a9 2233 Perl_croak(aTHX_ "Callback called exit");
f86702cc 2234 my_exit_jump();
4633a7c4 2235 /* NOTREACHED */
6224f72b 2236 case 3:
3280af22 2237 if (PL_restartop) {
533c011a 2238 PL_op = PL_restartop;
3280af22 2239 PL_restartop = 0;
312caa8e 2240 goto redo_body;
4633a7c4 2241 }
3280af22 2242 PL_stack_sp = PL_stack_base + oldmark;
4633a7c4
LW		 2243 if (flags & G_ARRAY)
2244 retval = 0;
2245 else {
2246 retval = 1;
3280af22 2247 *++PL_stack_sp = &PL_sv_undef;
4633a7c4 2248 }
312caa8e 2249 break;
4633a7c4
LW		 2250 }
2251
14dd3ad8 2252 JMPENV_POP;
4633a7c4 2253 if (flags & G_DISCARD) {
3280af22 2254 PL_stack_sp = PL_stack_base + oldmark;
4633a7c4
LW		 2255 retval = 0;
2256 FREETMPS;
2257 LEAVE;
2258 }
533c011a 2259 PL_op = oldop;
4633a7c4
LW		 2260 return retval;
2261}
2262
954c1994
GS		 2263/*
2264=for apidoc p||eval_pv
2265
2266Tells Perl to C<eval> the given string and return an SV* result.
2267
2268=cut
2269*/
2270
137443ea 2271SV*
864dbfa3 2272Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
137443ea 2273{
2274 dSP;
2275 SV* sv = newSVpv(p, 0);
2276
864dbfa3 2277 eval_sv(sv, G_SCALAR);
137443ea 2278 SvREFCNT_dec(sv);
2279
2280 SPAGAIN;
2281 sv = POPs;
2282 PUTBACK;
2283
2d8e6c8d
GS		 2284 if (croak_on_error && SvTRUE(ERRSV)) {
2285 STRLEN n_a;
cea2e8a9 2286 Perl_croak(aTHX_ SvPVx(ERRSV, n_a));
2d8e6c8d 2287 }
137443ea 2288
2289 return sv;
2290}
2291
4633a7c4
LW		 2292/* Require a module. */
2293
954c1994 2294/*
ccfc67b7
JH		 2295=head1 Embedding Functions
2296
954c1994
GS		 2297=for apidoc p||require_pv
2298
7d3fb230
BS		 2299Tells Perl to C<require> the file named by the string argument. It is
2300analogous to the Perl code C<eval "require '$file'">. It's even
2307c6d0 2301implemented that way; consider using load_module instead.
954c1994 2302
7d3fb230 2303=cut */
954c1994 2304
4633a7c4 2305void
864dbfa3 2306Perl_require_pv(pTHX_ const char *pv)
4633a7c4 2307{
d3acc0f7
JP		 2308 SV* sv;
2309 dSP;
e788e7d3 2310 PUSHSTACKi(PERLSI_REQUIRE);
d3acc0f7
JP		 2311 PUTBACK;
2312 sv = sv_newmortal();
4633a7c4
LW		 2313 sv_setpv(sv, "require '");
2314 sv_catpv(sv, pv);
2315 sv_catpv(sv, "'");
864dbfa3 2316 eval_sv(sv, G_DISCARD);
d3acc0f7
JP		 2317 SPAGAIN;
2318 POPSTACK;
79072805
LW		 2319}
2320
79072805 2321void
864dbfa3 2322Perl_magicname(pTHX_ char *sym, char *name, I32 namlen)
79072805
LW		 2323{
2324 register GV *gv;
2325
155aba94 2326 if ((gv = gv_fetchpv(sym,TRUE, SVt_PV)))
14befaf4 2327 sv_magic(GvSV(gv), (SV*)gv, PERL_MAGIC_sv, name, namlen);
79072805
LW		 2328}
2329
76e3520e 2330STATIC void
cea2e8a9 2331S_usage(pTHX_ char *name) /* XXX move this out into a module ? */
4633a7c4 2332{
ab821d7f 2333 /* This message really ought to be max 23 lines.
75c72d73 2334 * Removed -h because the user already knows that option. Others? */
fb73857a 2335
76e3520e 2336 static char *usage_msg[] = {
fb73857a 2337"-0[octal] specify record separator (\\0, if no argument)",
2338"-a autosplit mode with -n or -p (splits $_ into @F)",
fb3560ee 2339"-C[number/list] enables the listed Unicode features",
1950ee41 2340"-c check syntax only (runs BEGIN and CHECK blocks)",
aac3bd0d
GS		 2341"-d[:debugger] run program under debugger",
2342"-D[number/list] set debugging flags (argument is a bit mask or alphabets)",
90490ea3 2343"-e program one line of program (several -e's allowed, omit programfile)",
aac3bd0d
GS		 2344"-F/pattern/ split() pattern for -a switch (//'s are optional)",
2345"-i[extension] edit <> files in place (makes backup if extension supplied)",
2346"-Idirectory specify @INC/#include directory (several -I's allowed)",
fb73857a 2347"-l[octal] enable line ending processing, specifies line terminator",
aac3bd0d
GS		 2348"-[mM][-]module execute `use/no module...' before executing program",
2349"-n assume 'while (<>) { ... }' loop around program",
2350"-p assume loop like -n but print line also, like sed",
2351"-P run program through C preprocessor before compilation",
2352"-s enable rudimentary parsing for switches after programfile",
2353"-S look for programfile using PATH environment variable",
9cbc33e8 2354"-t enable tainting warnings",
90490ea3 2355"-T enable tainting checks",
aac3bd0d 2356"-u dump core after parsing program",
fb73857a 2357"-U allow unsafe operations",
aac3bd0d
GS		 2358"-v print version, subversion (includes VERY IMPORTANT perl info)",
2359"-V[:variable] print configuration summary (or a single Config.pm variable)",
2360"-w enable many useful warnings (RECOMMENDED)",
3c0facb2 2361"-W enable all warnings",
fb73857a 2362"-x[directory] strip off text before #!perl line and perhaps cd to directory",
90490ea3 2363"-X disable all warnings",
fb73857a 2364"\n",
2365NULL
2366};
76e3520e 2367 char **p = usage_msg;
fb73857a 2368
b0e47665
GS		 2369 PerlIO_printf(PerlIO_stdout(),
2370 "\nUsage: %s [switches] [--] [programfile] [arguments]",
2371 name);
fb73857a 2372 while (*p)
b0e47665 2373 PerlIO_printf(PerlIO_stdout(), "\n %s", *p++);
4633a7c4
LW		 2374}
2375
b4ab917c
DM		 2376/* convert a string of -D options (or digits) into an int.
2377 * sets *s to point to the char after the options */
2378
2379#ifdef DEBUGGING
2380int
2381Perl_get_debug_opts(pTHX_ char **s)
2382{
e6e64d9b
JC		 2383 static char *usage_msgd[] = {
2384 " Debugging flag values: (see also -d)",
2385 " p Tokenizing and parsing (with v, displays parse stack)",
2386 " s Stack snapshots. with v, displays all stacks",
2387 " l Context (loop) stack processing",
2388 " t Trace execution",
2389 " o Method and overloading resolution",
2390 " c String/numeric conversions",
2391 " P Print profiling info, preprocessor command for -P, source file input state",
2392 " m Memory allocation",
2393 " f Format processing",
2394 " r Regular expression parsing and execution",
2395 " x Syntax tree dump",
2396 " u Tainting checks (Obsolete, previously used for LEAKTEST)",
2397 " H Hash dump -- usurps values()",
2398 " X Scratchpad allocation",
2399 " D Cleaning up",
2400 " S Thread synchronization",
2401 " T Tokenising",
2402 " R Include reference counts of dumped variables (eg when using -Ds)",
2403 " J Do not s,t,P-debug (Jump over) opcodes within package DB",
2404 " v Verbose: use in conjunction with other flags",
2405 " C Copy On Write",
2406 " A Consistency checks on internal structures",
2407 " q quiet - currently only suppressed the 'EXECUTING' message",
2408 NULL
2409 };
b4ab917c
DM		 2410 int i = 0;
2411 if (isALPHA(**s)) {
2412 /* if adding extra options, remember to update DEBUG_MASK */
ecae49c0 2413 static char debopts[] = "psltocPmfrxu HXDSTRJvCAq";
b4ab917c
DM		 2414
2415 for (; isALNUM(**s); (*s)++) {
2416 char *d = strchr(debopts,**s);
2417 if (d)
2418 i |= 1 << (d - debopts);
2419 else if (ckWARN_d(WARN_DEBUGGING))
e6e64d9b
JC		 2420 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
2421 "invalid option -D%c, use -D'' to see choices\n", **s);
b4ab917c
DM		 2422 }
2423 }
e6e64d9b 2424 else if (isDIGIT(**s)) {
b4ab917c
DM		 2425 i = atoi(*s);
2426 for (; isALNUM(**s); (*s)++) ;
2427 }
e6e64d9b
JC		 2428 else {
2429 char **p = usage_msgd;
2430 while (*p) PerlIO_printf(PerlIO_stdout(), "%s\n", *p++);
2431 }
b4ab917c
DM		 2432# ifdef EBCDIC
2433 if ((i & DEBUG_p_FLAG) && ckWARN_d(WARN_DEBUGGING))
2434 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
2435 "-Dp not implemented on this platform\n");
2436# endif
2437 return i;
2438}
2439#endif
2440
79072805
LW		 2441/* This routine handles any switches that can be given during run */
2442
2443char *
864dbfa3 2444Perl_moreswitches(pTHX_ char *s)
79072805 2445{
ba210ebe 2446 STRLEN numlen;
84c133a0 2447 UV rschar;
79072805
LW		 2448
2449 switch (*s) {
2450 case '0':
a863c7d1 2451 {
f2095865
JH		 2452 I32 flags = 0;
2453
2454 SvREFCNT_dec(PL_rs);
2455 if (s[1] == 'x' && s[2]) {
2456 char *e;
2457 U8 *tmps;
2458
2459 for (s += 2, e = s; *e; e++);
2460 numlen = e - s;
2461 flags = PERL_SCAN_SILENT_ILLDIGIT;
2462 rschar = (U32)grok_hex(s, &numlen, &flags, NULL);
2463 if (s + numlen < e) {
2464 rschar = 0; /* Grandfather -0xFOO as -0 -xFOO. */
2465 numlen = 0;
2466 s--;
2467 }
2468 PL_rs = newSVpvn("", 0);
c5661c80 2469 SvGROW(PL_rs, (STRLEN)(UNISKIP(rschar) + 1));
f2095865
JH		 2470 tmps = (U8*)SvPVX(PL_rs);
2471 uvchr_to_utf8(tmps, rschar);
2472 SvCUR_set(PL_rs, UNISKIP(rschar));
2473 SvUTF8_on(PL_rs);
2474 }
2475 else {
2476 numlen = 4;
2477 rschar = (U32)grok_oct(s, &numlen, &flags, NULL);
2478 if (rschar & ~((U8)~0))
2479 PL_rs = &PL_sv_undef;
2480 else if (!rschar && numlen >= 2)
2481 PL_rs = newSVpvn("", 0);
2482 else {
2483 char ch = (char)rschar;
2484 PL_rs = newSVpvn(&ch, 1);
2485 }
2486 }
800633c3 2487 sv_setsv(get_sv("/", TRUE), PL_rs);
f2095865 2488 return s + numlen;
a863c7d1 2489 }
46487f74 2490 case 'C':
a05d7ebb
JH		 2491 s++;
2492 PL_unicode = parse_unicode_opts(&s);
46487f74 2493 return s;
2304df62 2494 case 'F':
3280af22 2495 PL_minus_F = TRUE;
ebce5377
RGS		 2496 PL_splitstr = ++s;
2497 while (*s && !isSPACE(*s)) ++s;
2498 *s = '\0';
2499 PL_splitstr = savepv(PL_splitstr);
2304df62 2500 return s;
79072805 2501 case 'a':
3280af22 2502 PL_minus_a = TRUE;
79072805
LW		 2503 s++;
2504 return s;
2505 case 'c':
3280af22 2506 PL_minus_c = TRUE;
79072805
LW		 2507 s++;
2508 return s;
2509 case 'd':
bbce6d69 2510 forbid_setid("-d");
4633a7c4 2511 s++;
70c94a19
RR		 2512 /* The following permits -d:Mod to accepts arguments following an =
2513 in the fashion that -MSome::Mod does. */
2514 if (*s == ':' || *s == '=') {
2515 char *start;
2516 SV *sv;
2517 sv = newSVpv("use Devel::", 0);
2518 start = ++s;
2519 /* We now allow -d:Module=Foo,Bar */
2520 while(isALNUM(*s) || *s==':') ++s;
2521 if (*s != '=')
2522 sv_catpv(sv, start);
2523 else {
2524 sv_catpvn(sv, start, s-start);
2525 sv_catpv(sv, " split(/,/,q{");
2526 sv_catpv(sv, ++s);
3d27e215 2527 sv_catpv(sv, "})");
70c94a19 2528 }
4633a7c4 2529 s += strlen(s);
70c94a19 2530 my_setenv("PERL5DB", SvPV(sv, PL_na));
4633a7c4 2531 }
ed094faf 2532 if (!PL_perldb) {
3280af22 2533 PL_perldb = PERLDB_ALL;
a0d0e21e 2534 init_debugger();
ed094faf 2535 }
79072805
LW		 2536 return s;
2537 case 'D':
0453d815 2538 {
79072805 2539#ifdef DEBUGGING
bbce6d69 2540 forbid_setid("-D");
b4ab917c
DM		 2541 s++;
2542 PL_debug = get_debug_opts(&s) | DEBUG_TOP_FLAG;
12a43e32 2543#else /* !DEBUGGING */
0453d815 2544 if (ckWARN_d(WARN_DEBUGGING))
9014280d 2545 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
e6e64d9b 2546 "Recompile perl with -DDEBUGGING to use -D switch (did you mean -d ?)\n");
a0d0e21e 2547 for (s++; isALNUM(*s); s++) ;
79072805
LW		 2548#endif
2549 /*SUPPRESS 530*/
2550 return s;
0453d815 2551 }
4633a7c4 2552 case 'h':
ac27b0f5 2553 usage(PL_origargv[0]);
7ca617d0 2554 my_exit(0);
79072805 2555 case 'i':
3280af22
NIS		 2556 if (PL_inplace)
2557 Safefree(PL_inplace);
c030f24b
GH		 2558#if defined(__CYGWIN__) /* do backup extension automagically */
2559 if (*(s+1) == '\0') {
2560 PL_inplace = savepv(".bak");
2561 return s+1;
2562 }
2563#endif /* __CYGWIN__ */
3280af22 2564 PL_inplace = savepv(s+1);
79072805 2565 /*SUPPRESS 530*/
3280af22 2566 for (s = PL_inplace; *s && !isSPACE(*s); s++) ;
7b8d334a 2567 if (*s) {
fb73857a 2568 *s++ = '\0';
7b8d334a
GS		 2569 if (*s == '-') /* Additional switches on #! line. */
2570 s++;
2571 }
fb73857a 2572 return s;
4e49a025 2573 case 'I': /* -I handled both here and in parse_body() */
bbce6d69 2574 forbid_setid("-I");
fb73857a 2575 ++s;
2576 while (*s && isSPACE(*s))
2577 ++s;
2578 if (*s) {
774d564b 2579 char *e, *p;
0df16ed7
GS		 2580 p = s;
2581 /* ignore trailing spaces (possibly followed by other switches) */
2582 do {
2583 for (e = p; *e && !isSPACE(*e); e++) ;
2584 p = e;
2585 while (isSPACE(*p))
2586 p++;
2587 } while (*p && *p != '-');
2588 e = savepvn(s, e-s);
574c798a 2589 incpush(e, TRUE, TRUE, FALSE);
0df16ed7
GS		 2590 Safefree(e);
2591 s = p;
2592 if (*s == '-')
2593 s++;
79072805
LW		 2594 }
2595 else
a67e862a 2596 Perl_croak(aTHX_ "No directory specified for -I");
fb73857a 2597 return s;
79072805 2598 case 'l':
3280af22 2599 PL_minus_l = TRUE;
79072805 2600 s++;
7889fe52
NIS		 2601 if (PL_ors_sv) {
2602 SvREFCNT_dec(PL_ors_sv);
2603 PL_ors_sv = Nullsv;
2604 }
79072805 2605 if (isDIGIT(*s)) {
53305cf1 2606 I32 flags = 0;
7889fe52 2607 PL_ors_sv = newSVpvn("\n",1);
53305cf1
NC		 2608 numlen = 3 + (*s == '0');
2609 *SvPVX(PL_ors_sv) = (char)grok_oct(s, &numlen, &flags, NULL);
79072805
LW		 2610 s += numlen;
2611 }
2612 else {
8bfdd7d9 2613 if (RsPARA(PL_rs)) {
7889fe52
NIS		 2614 PL_ors_sv = newSVpvn("\n\n",2);
2615 }
2616 else {
8bfdd7d9 2617 PL_ors_sv = newSVsv(PL_rs);
c07a80fd 2618 }
79072805
LW		 2619 }
2620 return s;
06492da6
SF		 2621 case 'A':
2622 forbid_setid("-A");
930366bd
RGS		 2623 if (!PL_preambleav)
2624 PL_preambleav = newAV();
06492da6 2625 if (*++s) {
3d27e215
LM		 2626 SV *sv = newSVpv("use assertions::activate split(/,/,q", 0);
2627 sv_catpvn(sv, "\0", 1); /* Use NUL as q//-delimiter. */
06492da6 2628 sv_catpv(sv,s);
3d27e215 2629 sv_catpvn(sv, "\0)", 2);
06492da6 2630 s+=strlen(s);
06492da6
SF		 2631 av_push(PL_preambleav, sv);
2632 }
2633 else
930366bd 2634 av_push(PL_preambleav, newSVpvn("use assertions::activate",24));
06492da6 2635 return s;
1a30305b 2636 case 'M':
bbce6d69 2637 forbid_setid("-M"); /* XXX ? */
1a30305b 2638 /* FALL THROUGH */
2639 case 'm':
bbce6d69 2640 forbid_setid("-m"); /* XXX ? */
1a30305b 2641 if (*++s) {
a5f75d66 2642 char *start;
11343788 2643 SV *sv;
a5f75d66
AD		 2644 char *use = "use ";
2645 /* -M-foo == 'no foo' */
2646 if (*s == '-') { use = "no "; ++s; }
11343788 2647 sv = newSVpv(use,0);
a5f75d66 2648 start = s;
1a30305b 2649 /* We allow -M'Module qw(Foo Bar)' */
c07a80fd 2650 while(isALNUM(*s) || *s==':') ++s;
2651 if (*s != '=') {
11343788 2652 sv_catpv(sv, start);
c07a80fd 2653 if (*(start-1) == 'm') {
2654 if (*s != '\0')
cea2e8a9 2655 Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
11343788 2656 sv_catpv( sv, " ()");
c07a80fd 2657 }
2658 } else {
6df41af2 2659 if (s == start)
be98fb35
GS		 2660 Perl_croak(aTHX_ "Module name required with -%c option",
2661 s[-1]);
11343788 2662 sv_catpvn(sv, start, s-start);
3d27e215
LM		 2663 sv_catpv(sv, " split(/,/,q");
2664 sv_catpvn(sv, "\0)", 1); /* Use NUL as q//-delimiter. */
11343788 2665 sv_catpv(sv, ++s);
3d27e215 2666 sv_catpvn(sv, "\0)", 2);
c07a80fd 2667 }
1a30305b 2668 s += strlen(s);
5c831c24 2669 if (!PL_preambleav)
3280af22
NIS		 2670 PL_preambleav = newAV();
2671 av_push(PL_preambleav, sv);
1a30305b 2672 }
2673 else
cea2e8a9 2674 Perl_croak(aTHX_ "No space allowed after -%c", *(s-1));
1a30305b 2675 return s;
79072805 2676 case 'n':
3280af22 2677 PL_minus_n = TRUE;
79072805
LW		 2678 s++;
2679 return s;
2680 case 'p':
3280af22 2681 PL_minus_p = TRUE;
79072805
LW		 2682 s++;
2683 return s;
2684 case 's':
bbce6d69 2685 forbid_setid("-s");
3280af22 2686 PL_doswitches = TRUE;
79072805
LW		 2687 s++;
2688 return s;
6537fe72
MS		 2689 case 't':
2690 if (!PL_tainting)
22f7c9c9 2691 TOO_LATE_FOR('t');
6537fe72
MS		 2692 s++;
2693 return s;
463ee0b2 2694 case 'T':
3280af22 2695 if (!PL_tainting)
22f7c9c9 2696 TOO_LATE_FOR('T');
463ee0b2
LW		 2697 s++;
2698 return s;
79072805 2699 case 'u':
bf4acbe4
GS		 2700#ifdef MACOS_TRADITIONAL
2701 Perl_croak(aTHX_ "Believe me, you don't want to use \"-u\" on a Macintosh");
2702#endif
3280af22 2703 PL_do_undump = TRUE;
79072805
LW		 2704 s++;
2705 return s;
2706 case 'U':
3280af22 2707 PL_unsafe = TRUE;
79072805
LW		 2708 s++;
2709 return s;
2710 case 'v':
8e9464f1 2711#if !defined(DGUX)
b0e47665 2712 PerlIO_printf(PerlIO_stdout(),
d2560b70 2713 Perl_form(aTHX_ "\nThis is perl, v%"VDf" built for %s",
b0e47665 2714 PL_patchlevel, ARCHNAME));
8e9464f1
JH		 2715#else /* DGUX */
2716/* Adjust verbose output as in the perl that ships with the DG/UX OS from EMC */
2717 PerlIO_printf(PerlIO_stdout(),
2718 Perl_form(aTHX_ "\nThis is perl, version %vd\n", PL_patchlevel));
2719 PerlIO_printf(PerlIO_stdout(),
2720 Perl_form(aTHX_ " built under %s at %s %s\n",
2721 OSNAME, __DATE__, __TIME__));
2722 PerlIO_printf(PerlIO_stdout(),
2723 Perl_form(aTHX_ " OS Specific Release: %s\n",
40a39f85 2724 OSVERS));
8e9464f1
JH		 2725#endif /* !DGUX */
2726
fb73857a 2727#if defined(LOCAL_PATCH_COUNT)
2728 if (LOCAL_PATCH_COUNT > 0)
b0e47665
GS		 2729 PerlIO_printf(PerlIO_stdout(),
2730 "\n(with %d registered patch%s, "
2731 "see perl -V for more detail)",
2732 (int)LOCAL_PATCH_COUNT,
2733 (LOCAL_PATCH_COUNT!=1) ? "es" : "");
a5f75d66 2734#endif
1a30305b 2735
b0e47665 2736 PerlIO_printf(PerlIO_stdout(),
45a2796c 2737 "\n\nCopyright 1987-2004, Larry Wall\n");
eae9c151
JH		 2738#ifdef MACOS_TRADITIONAL
2739 PerlIO_printf(PerlIO_stdout(),
be3c0a43 2740 "\nMac OS port Copyright 1991-2002, Matthias Neeracher;\n"
03765510 2741 "maintained by Chris Nandor\n");
eae9c151 2742#endif
79072805 2743#ifdef MSDOS
b0e47665
GS		 2744 PerlIO_printf(PerlIO_stdout(),
2745 "\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
55497cff 2746#endif
2747#ifdef DJGPP
b0e47665
GS		 2748 PerlIO_printf(PerlIO_stdout(),
2749 "djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n"
2750 "djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
4633a7c4 2751#endif
79072805 2752#ifdef OS2
b0e47665
GS		 2753 PerlIO_printf(PerlIO_stdout(),
2754 "\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
be3c0a43 2755 "Version 5 port Copyright (c) 1994-2002, Andreas Kaiser, Ilya Zakharevich\n");
79072805 2756#endif
79072805 2757#ifdef atarist
b0e47665
GS		 2758 PerlIO_printf(PerlIO_stdout(),
2759 "atariST series port, ++jrb bammi@cadence.com\n");
79072805 2760#endif
a3f9223b 2761#ifdef __BEOS__
b0e47665
GS		 2762 PerlIO_printf(PerlIO_stdout(),
2763 "BeOS port Copyright Tom Spindler, 1997-1999\n");
a3f9223b 2764#endif
1d84e8df 2765#ifdef MPE
b0e47665 2766 PerlIO_printf(PerlIO_stdout(),
e583a879 2767 "MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-2003\n");
1d84e8df 2768#endif
9d116dd7 2769#ifdef OEMVS
b0e47665
GS		 2770 PerlIO_printf(PerlIO_stdout(),
2771 "MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
9d116dd7 2772#endif
495c5fdc 2773#ifdef __VOS__
b0e47665 2774 PerlIO_printf(PerlIO_stdout(),
94efb9fb 2775 "Stratus VOS port by Paul.Green@stratus.com, 1997-2002\n");
495c5fdc 2776#endif
092bebab 2777#ifdef __OPEN_VM
b0e47665
GS		 2778 PerlIO_printf(PerlIO_stdout(),
2779 "VM/ESA port by Neale Ferguson, 1998-1999\n");
092bebab 2780#endif
a1a0e61e 2781#ifdef POSIX_BC
b0e47665
GS		 2782 PerlIO_printf(PerlIO_stdout(),
2783 "BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
a1a0e61e 2784#endif
61ae2fbf 2785#ifdef __MINT__
b0e47665
GS		 2786 PerlIO_printf(PerlIO_stdout(),
2787 "MiNT port by Guido Flohr, 1997-1999\n");
61ae2fbf 2788#endif
f83d2536 2789#ifdef EPOC
b0e47665 2790 PerlIO_printf(PerlIO_stdout(),
be3c0a43 2791 "EPOC port by Olaf Flebbe, 1999-2002\n");
f83d2536 2792#endif
e1caacb4 2793#ifdef UNDER_CE
b475b3e6
JH		 2794 PerlIO_printf(PerlIO_stdout(),"WINCE port by Rainer Keuchel, 2001-2002\n");
2795 PerlIO_printf(PerlIO_stdout(),"Built on " __DATE__ " " __TIME__ "\n\n");
e1caacb4
JH		 2796 wce_hitreturn();
2797#endif
baed7233
DL		 2798#ifdef BINARY_BUILD_NOTICE
2799 BINARY_BUILD_NOTICE;
2800#endif
b0e47665
GS		 2801 PerlIO_printf(PerlIO_stdout(),
2802 "\n\
79072805 2803Perl may be copied only under the terms of either the Artistic License or the\n\
3d6f292d 2804GNU General Public License, which may be found in the Perl 5 source kit.\n\n\
95103687
GS		 2805Complete documentation for Perl, including FAQ lists, should be found on\n\
2806this system using `man perl' or `perldoc perl'. If you have access to the\n\
2807Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n");
7ca617d0 2808 my_exit(0);
79072805 2809 case 'w':
599cee73 2810 if (! (PL_dowarn & G_WARN_ALL_MASK))
ac27b0f5 2811 PL_dowarn |= G_WARN_ON;
599cee73
PM		 2812 s++;
2813 return s;
2814 case 'W':
ac27b0f5 2815 PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
317ea90d
MS		 2816 if (!specialWARN(PL_compiling.cop_warnings))
2817 SvREFCNT_dec(PL_compiling.cop_warnings);
d3a7d8c7 2818 PL_compiling.cop_warnings = pWARN_ALL ;
599cee73
PM		 2819 s++;
2820 return s;
2821 case 'X':
ac27b0f5 2822 PL_dowarn = G_WARN_ALL_OFF;
317ea90d
MS		 2823 if (!specialWARN(PL_compiling.cop_warnings))
2824 SvREFCNT_dec(PL_compiling.cop_warnings);
d3a7d8c7 2825 PL_compiling.cop_warnings = pWARN_NONE ;
79072805
LW		 2826 s++;
2827 return s;
a0d0e21e 2828 case '*':
79072805
LW		 2829 case ' ':
2830 if (s[1] == '-') /* Additional switches on #! line. */
2831 return s+2;
2832 break;
a0d0e21e 2833 case '-':
79072805 2834 case 0:
51882d45 2835#if defined(WIN32) || !defined(PERL_STRICT_CR)
a868473f
NIS		 2836 case '\r':
2837#endif
79072805
LW		 2838 case '\n':
2839 case '\t':
2840 break;
aa689395 2841#ifdef ALTERNATE_SHEBANG
2842 case 'S': /* OS/2 needs -S on "extproc" line. */
2843 break;
2844#endif
a0d0e21e 2845 case 'P':
3280af22 2846 if (PL_preprocess)
a0d0e21e
LW		 2847 return s+1;
2848 /* FALL THROUGH */
79072805 2849 default:
cea2e8a9 2850 Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
79072805
LW		 2851 }
2852 return Nullch;
2853}
2854
2855/* compliments of Tom Christiansen */
2856
2857/* unexec() can be found in the Gnu emacs distribution */
ee580363 2858/* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
79072805
LW		 2859
2860void
864dbfa3 2861Perl_my_unexec(pTHX)
79072805
LW		 2862{
2863#ifdef UNEXEC
46fc3d4c 2864 SV* prog;
2865 SV* file;
ee580363 2866 int status = 1;
79072805
LW		 2867 extern int etext;
2868
ee580363 2869 prog = newSVpv(BIN_EXP, 0);
46fc3d4c 2870 sv_catpv(prog, "/perl");
6b88bc9c 2871 file = newSVpv(PL_origfilename, 0);
46fc3d4c 2872 sv_catpv(file, ".perldump");
79072805 2873
ee580363
GS		 2874 unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
2875 /* unexec prints msg to stderr in case of failure */
6ad3d225 2876 PerlProc_exit(status);
79072805 2877#else
a5f75d66
AD		 2878# ifdef VMS
2879# include <lib$routines.h>
2880 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
aa689395 2881# else
79072805 2882 ABORT(); /* for use with undump */
aa689395 2883# endif
a5f75d66 2884#endif
79072805
LW		 2885}
2886
cb68f92d
GS		 2887/* initialize curinterp */
2888STATIC void
cea2e8a9 2889S_init_interp(pTHX)
cb68f92d
GS		 2890{
2891
acfe0abc
GS		 2892#ifdef MULTIPLICITY
2893# define PERLVAR(var,type)
2894# define PERLVARA(var,n,type)
2895# if defined(PERL_IMPLICIT_CONTEXT)
2896# if defined(USE_5005THREADS)
2897# define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
c5be433b 2898# define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
acfe0abc
GS		 2899# else /* !USE_5005THREADS */
2900# define PERLVARI(var,type,init) aTHX->var = init;
2901# define PERLVARIC(var,type,init) aTHX->var = init;
2902# endif /* USE_5005THREADS */
3967c732 2903# else
acfe0abc
GS		 2904# define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
2905# define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
066ef5b5 2906# endif
acfe0abc
GS		 2907# include "intrpvar.h"
2908# ifndef USE_5005THREADS
2909# include "thrdvar.h"
2910# endif
2911# undef PERLVAR
2912# undef PERLVARA
2913# undef PERLVARI
2914# undef PERLVARIC
2915#else
2916# define PERLVAR(var,type)
2917# define PERLVARA(var,n,type)
2918# define PERLVARI(var,type,init) PL_##var = init;
2919# define PERLVARIC(var,type,init) PL_##var = init;
2920# include "intrpvar.h"
2921# ifndef USE_5005THREADS
2922# include "thrdvar.h"
2923# endif
2924# undef PERLVAR
2925# undef PERLVARA
2926# undef PERLVARI
2927# undef PERLVARIC
cb68f92d
GS		 2928#endif
2929
cb68f92d
GS		 2930}
2931
76e3520e 2932STATIC void
cea2e8a9 2933S_init_main_stash(pTHX)
79072805 2934{
463ee0b2 2935 GV *gv;
6e72f9df 2936
3280af22 2937 PL_curstash = PL_defstash = newHV();
79cb57f6 2938 PL_curstname = newSVpvn("main",4);
adbc6bb1
LW		 2939 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
2940 SvREFCNT_dec(GvHV(gv));
3280af22 2941 GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);
463ee0b2 2942 SvREADONLY_on(gv);
3280af22
NIS		 2943 HvNAME(PL_defstash) = savepv("main");
2944 PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
2945 GvMULTI_on(PL_incgv);
2946 PL_hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */
2947 GvMULTI_on(PL_hintgv);
2948 PL_defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
2949 PL_errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
2950 GvMULTI_on(PL_errgv);
2951 PL_replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */
2952 GvMULTI_on(PL_replgv);
cea2e8a9 2953 (void)Perl_form(aTHX_ "%240s",""); /* Preallocate temp - for immediate signals. */
38a03e6e
MB		 2954 sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
2955 sv_setpvn(ERRSV, "", 0);
3280af22 2956 PL_curstash = PL_defstash;
11faa288 2957 CopSTASH_set(&PL_compiling, PL_defstash);
ed094faf 2958 PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
3280af22 2959 PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
4633a7c4 2960 /* We must init $/ before switches are processed. */
864dbfa3 2961 sv_setpvn(get_sv("/", TRUE), "\n", 1);
79072805
LW		 2962}
2963
ae3f3efd 2964/* PSz 18 Nov 03 fdscript now global but do not change prototype */
76e3520e 2965STATIC void
c5cccb17 2966S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv)
79072805 2967{
ae3f3efd 2968#ifndef IAMSUID
1b24ed4b
MS		 2969 char *quote;
2970 char *code;
2971 char *cpp_discard_flag;
2972 char *perl;
ae3f3efd 2973#endif
1b24ed4b 2974
ae3f3efd
PS		 2975 PL_fdscript = -1;
2976 PL_suidscript = -1;
79072805 2977
3280af22
NIS		 2978 if (PL_e_script) {
2979 PL_origfilename = savepv("-e");
96436eeb 2980 }
6c4ab083
GS		 2981 else {
2982 /* if find_script() returns, it returns a malloc()-ed value */
3280af22 2983 PL_origfilename = scriptname = find_script(scriptname, dosearch, NULL, 1);
6c4ab083
GS		 2984
2985 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
2986 char *s = scriptname + 8;
ae3f3efd 2987 PL_fdscript = atoi(s);
6c4ab083
GS		 2988 while (isDIGIT(*s))
2989 s++;
2990 if (*s) {
ae3f3efd
PS		 2991 /* PSz 18 Feb 04
2992 * Tell apart "normal" usage of fdscript, e.g.
2993 * with bash on FreeBSD:
2994 * perl <( echo '#!perl -DA'; echo 'print "$0\n"')
2995 * from usage in suidperl.
2996 * Does any "normal" usage leave garbage after the number???
2997 * Is it a mistake to use a similar /dev/fd/ construct for
2998 * suidperl?
2999 */
3000 PL_suidscript = 1;
3001 /* PSz 20 Feb 04
3002 * Be supersafe and do some sanity-checks.
3003 * Still, can we be sure we got the right thing?
3004 */
3005 if (*s != '/') {
3006 Perl_croak(aTHX_ "Wrong syntax (suid) fd script name \"%s\"\n", s);
3007 }
3008 if (! *(s+1)) {
3009 Perl_croak(aTHX_ "Missing (suid) fd script name\n");
3010 }
6c4ab083 3011 scriptname = savepv(s + 1);
3280af22
NIS		 3012 Safefree(PL_origfilename);
3013 PL_origfilename = scriptname;
6c4ab083
GS		 3014 }
3015 }
3016 }
3017
05ec9bb3 3018 CopFILE_free(PL_curcop);
57843af0 3019 CopFILE_set(PL_curcop, PL_origfilename);
3280af22 3020 if (strEQ(PL_origfilename,"-"))
79072805 3021 scriptname = "";
ae3f3efd
PS		 3022 if (PL_fdscript >= 0) {
3023 PL_rsfp = PerlIO_fdopen(PL_fdscript,PERL_SCRIPT_MODE);
1b24ed4b
MS		 3024# if defined(HAS_FCNTL) && defined(F_SETFD)
3025 if (PL_rsfp)
3026 /* ensure close-on-exec */
3027 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);
3028# endif
96436eeb 3029 }
ae3f3efd
PS		 3030#ifdef IAMSUID
3031 else {
86207487
NC		 3032 Perl_croak(aTHX_ "sperl needs fd script\n"
3033 "You should not call sperl directly; do you need to "
3034 "change a #! line\nfrom sperl to perl?\n");
3035
ae3f3efd
PS		 3036/* PSz 11 Nov 03
3037 * Do not open (or do other fancy stuff) while setuid.
3038 * Perl does the open, and hands script to suidperl on a fd;
3039 * suidperl only does some checks, sets up UIDs and re-execs
3040 * perl with that fd as it has always done.
3041 */
3042 }
3043 if (PL_suidscript != 1) {
3044 Perl_croak(aTHX_ "suidperl needs (suid) fd script\n");
3045 }
3046#else /* IAMSUID */
3280af22 3047 else if (PL_preprocess) {
46fc3d4c 3048 char *cpp_cfg = CPPSTDIN;
79cb57f6 3049 SV *cpp = newSVpvn("",0);
46fc3d4c 3050 SV *cmd = NEWSV(0,0);
3051
ae58f265
JH		 3052 if (cpp_cfg[0] == 0) /* PERL_MICRO? */
3053 Perl_croak(aTHX_ "Can't run with cpp -P with CPPSTDIN undefined");
46fc3d4c 3054 if (strEQ(cpp_cfg, "cppstdin"))
cea2e8a9 3055 Perl_sv_catpvf(aTHX_ cpp, "%s/", BIN_EXP);
46fc3d4c 3056 sv_catpv(cpp, cpp_cfg);
79072805 3057
1b24ed4b
MS		 3058# ifndef VMS
3059 sv_catpvn(sv, "-I", 2);
3060 sv_catpv(sv,PRIVLIB_EXP);
3061# endif
46fc3d4c 3062
14953ddc
MB		 3063 DEBUG_P(PerlIO_printf(Perl_debug_log,
3064 "PL_preprocess: scriptname=\"%s\", cpp=\"%s\", sv=\"%s\", CPPMINUS=\"%s\"\n",
3065 scriptname, SvPVX (cpp), SvPVX (sv), CPPMINUS));
1b24ed4b
MS		 3066
3067# if defined(MSDOS) || defined(WIN32) || defined(VMS)
3068 quote = "\"";
3069# else
3070 quote = "'";
3071# endif
3072
3073# ifdef VMS
3074 cpp_discard_flag = "";
3075# else
3076 cpp_discard_flag = "-C";
3077# endif
3078
3079# ifdef OS2
3080 perl = os2_execname(aTHX);
3081# else
3082 perl = PL_origargv[0];
3083# endif
3084
3085
3086 /* This strips off Perl comments which might interfere with
62375a60
NIS		 3087 the C pre-processor, including #!. #line directives are
3088 deliberately stripped to avoid confusion with Perl's version
1b24ed4b
MS		 3089 of #line. FWP played some golf with it so it will fit
3090 into VMS's 255 character buffer.
3091 */
3092 if( PL_doextract )
3093 code = "(1../^#!.*perl/i)|/^\\s*#(?!\\s*((ifn?|un)def|(el|end)?if|define|include|else|error|pragma)\\b)/||!($|=1)||print";
3094 else
3095 code = "/^\\s*#(?!\\s*((ifn?|un)def|(el|end)?if|define|include|else|error|pragma)\\b)/||!($|=1)||print";
3096
3097 Perl_sv_setpvf(aTHX_ cmd, "\
3098%s -ne%s%s%s %s | %"SVf" %s %"SVf" %s",
62375a60 3099 perl, quote, code, quote, scriptname, cpp,
1b24ed4b
MS		 3100 cpp_discard_flag, sv, CPPMINUS);
3101
3280af22 3102 PL_doextract = FALSE;
0a6c758d 3103
62375a60
NIS		 3104 DEBUG_P(PerlIO_printf(Perl_debug_log,
3105 "PL_preprocess: cmd=\"%s\"\n",
0a6c758d
MS		 3106 SvPVX(cmd)));
3107
3280af22 3108 PL_rsfp = PerlProc_popen(SvPVX(cmd), "r");
46fc3d4c 3109 SvREFCNT_dec(cmd);
3110 SvREFCNT_dec(cpp);
79072805
LW		 3111 }
3112 else if (!*scriptname) {
bbce6d69 3113 forbid_setid("program input from stdin");
3280af22 3114 PL_rsfp = PerlIO_stdin();
79072805 3115 }
96436eeb 3116 else {
3280af22 3117 PL_rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
1b24ed4b
MS		 3118# if defined(HAS_FCNTL) && defined(F_SETFD)
3119 if (PL_rsfp)
3120 /* ensure close-on-exec */
3121 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);
3122# endif
96436eeb 3123 }
ae3f3efd 3124#endif /* IAMSUID */
3280af22 3125 if (!PL_rsfp) {
447218f8 3126 /* PSz 16 Sep 03 Keep neat error message */
fa3aa65a
JC		 3127 Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
3128 CopFILE(PL_curcop), Strerror(errno));
13281fa4 3129 }
79072805 3130}
8d063cd8 3131
7b89560d
JH		 3132/* Mention
3133 * I_SYSSTATVFS HAS_FSTATVFS
3134 * I_SYSMOUNT
c890dc6c 3135 * I_STATFS HAS_FSTATFS HAS_GETFSSTAT
7b89560d
JH		 3136 * I_MNTENT HAS_GETMNTENT HAS_HASMNTOPT
3137 * here so that metaconfig picks them up. */
3138
104d25b7 3139#ifdef IAMSUID
864dbfa3 3140STATIC int
e688b231 3141S_fd_on_nosuid_fs(pTHX_ int fd)
104d25b7 3142{
ae3f3efd
PS		 3143/* PSz 27 Feb 04
3144 * We used to do this as "plain" user (after swapping UIDs with setreuid);
3145 * but is needed also on machines without setreuid.
3146 * Seems safe enough to run as root.
3147 */
0545a864
JH		 3148 int check_okay = 0; /* able to do all the required sys/libcalls */
3149 int on_nosuid = 0; /* the fd is on a nosuid fs */
ae3f3efd
PS		 3150 /* PSz 12 Nov 03
3151 * Need to check noexec also: nosuid might not be set, the average
3152 * sysadmin would say that nosuid is irrelevant once he sets noexec.
3153 */
3154 int on_noexec = 0; /* the fd is on a noexec fs */
3155
104d25b7 3156/*
ad27e871 3157 * Preferred order: fstatvfs(), fstatfs(), ustat()+getmnt(), getmntent().
e688b231 3158 * fstatvfs() is UNIX98.
0545a864 3159 * fstatfs() is 4.3 BSD.
ad27e871 3160 * ustat()+getmnt() is pre-4.3 BSD.
0545a864
JH		 3161 * getmntent() is O(number-of-mounted-filesystems) and can hang on
3162 * an irrelevant filesystem while trying to reach the right one.
104d25b7
JH		 3163 */
3164
6439433f
JH		 3165#undef FD_ON_NOSUID_CHECK_OKAY /* found the syscalls to do the check? */
3166
3167# if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
3168 defined(HAS_FSTATVFS)
3169# define FD_ON_NOSUID_CHECK_OKAY
104d25b7 3170 struct statvfs stfs;
6439433f 3171
104d25b7
JH		 3172 check_okay = fstatvfs(fd, &stfs) == 0;
3173 on_nosuid = check_okay && (stfs.f_flag & ST_NOSUID);
ae3f3efd
PS		 3174#ifdef ST_NOEXEC
3175 /* ST_NOEXEC certainly absent on AIX 5.1, and doesn't seem to be documented
3176 on platforms where it is present. */
3177 on_noexec = check_okay && (stfs.f_flag & ST_NOEXEC);
3178#endif
6439433f 3179# endif /* fstatvfs */
ac27b0f5 3180
6439433f
JH		 3181# if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
3182 defined(PERL_MOUNT_NOSUID) && \
ae3f3efd 3183 defined(PERL_MOUNT_NOEXEC) && \
6439433f
JH		 3184 defined(HAS_FSTATFS) && \
3185 defined(HAS_STRUCT_STATFS) && \
3186 defined(HAS_STRUCT_STATFS_F_FLAGS)
3187# define FD_ON_NOSUID_CHECK_OKAY
e688b231 3188 struct statfs stfs;
6439433f 3189
104d25b7 3190 check_okay = fstatfs(fd, &stfs) == 0;
104d25b7 3191 on_nosuid = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID);
ae3f3efd 3192 on_noexec = check_okay && (stfs.f_flags & PERL_MOUNT_NOEXEC);
6439433f
JH		 3193# endif /* fstatfs */
3194
3195# if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
3196 defined(PERL_MOUNT_NOSUID) && \
ae3f3efd 3197 defined(PERL_MOUNT_NOEXEC) && \
6439433f
JH		 3198 defined(HAS_FSTAT) && \
3199 defined(HAS_USTAT) && \
3200 defined(HAS_GETMNT) && \
3201 defined(HAS_STRUCT_FS_DATA) && \
3202 defined(NOSTAT_ONE)
3203# define FD_ON_NOSUID_CHECK_OKAY
c623ac67 3204 Stat_t fdst;
6439433f 3205
0545a864 3206 if (fstat(fd, &fdst) == 0) {
6439433f
JH		 3207 struct ustat us;
3208 if (ustat(fdst.st_dev, &us) == 0) {
3209 struct fs_data fsd;
3210 /* NOSTAT_ONE here because we're not examining fields which
3211 * vary between that case and STAT_ONE. */
ad27e871 3212 if (getmnt((int*)0, &fsd, (int)0, NOSTAT_ONE, us.f_fname) == 0) {
6439433f
JH		 3213 size_t cmplen = sizeof(us.f_fname);
3214 if (sizeof(fsd.fd_req.path) < cmplen)
3215 cmplen = sizeof(fsd.fd_req.path);
3216 if (strnEQ(fsd.fd_req.path, us.f_fname, cmplen) &&
3217 fdst.st_dev == fsd.fd_req.dev) {
3218 check_okay = 1;
3219 on_nosuid = fsd.fd_req.flags & PERL_MOUNT_NOSUID;
ae3f3efd 3220 on_noexec = fsd.fd_req.flags & PERL_MOUNT_NOEXEC;
6439433f
JH		 3221 }
3222 }
3223 }
3224 }
0545a864 3225 }
6439433f
JH		 3226# endif /* fstat+ustat+getmnt */
3227
3228# if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
3229 defined(HAS_GETMNTENT) && \
3230 defined(HAS_HASMNTOPT) && \
ae3f3efd
PS		 3231 defined(MNTOPT_NOSUID) && \
3232 defined(MNTOPT_NOEXEC)
6439433f
JH		 3233# define FD_ON_NOSUID_CHECK_OKAY
3234 FILE *mtab = fopen("/etc/mtab", "r");
3235 struct mntent *entry;
c623ac67 3236 Stat_t stb, fsb;
104d25b7
JH		 3237
3238 if (mtab && (fstat(fd, &stb) == 0)) {
6439433f
JH		 3239 while (entry = getmntent(mtab)) {
3240 if (stat(entry->mnt_dir, &fsb) == 0
3241 && fsb.st_dev == stb.st_dev)
3242 {
3243 /* found the filesystem */
3244 check_okay = 1;
3245 if (hasmntopt(entry, MNTOPT_NOSUID))
3246 on_nosuid = 1;
ae3f3efd
PS		 3247 if (hasmntopt(entry, MNTOPT_NOEXEC))
3248 on_noexec = 1;
6439433f
JH		 3249 break;
3250 } /* A single fs may well fail its stat(). */
3251 }
104d25b7
JH		 3252 }
3253 if (mtab)
6439433f
JH		 3254 fclose(mtab);
3255# endif /* getmntent+hasmntopt */
0545a864 3256
ac27b0f5 3257 if (!check_okay)
ae3f3efd
PS		 3258 Perl_croak(aTHX_ "Can't check filesystem of script \"%s\" for nosuid/noexec", PL_origfilename);
3259 if (on_nosuid)
3260 Perl_croak(aTHX_ "Setuid script \"%s\" on nosuid filesystem", PL_origfilename);
3261 if (on_noexec)
3262 Perl_croak(aTHX_ "Setuid script \"%s\" on noexec filesystem", PL_origfilename);
3263 return ((!check_okay) || on_nosuid || on_noexec);
104d25b7
JH		 3264}
3265#endif /* IAMSUID */
3266
76e3520e 3267STATIC void
c5cccb17 3268S_validate_suid(pTHX_ char *validarg, char *scriptname)
79072805 3269{
155aba94 3270#ifdef IAMSUID
ae3f3efd
PS		 3271 /* int which; */
3272#endif /* IAMSUID */
96436eeb 3273
13281fa4
LW		 3274 /* do we need to emulate setuid on scripts? */
3275
3276 /* This code is for those BSD systems that have setuid #! scripts disabled
3277 * in the kernel because of a security problem. Merely defining DOSUID
3278 * in perl will not fix that problem, but if you have disabled setuid
3279 * scripts in the kernel, this will attempt to emulate setuid and setgid
3280 * on scripts that have those now-otherwise-useless bits set. The setuid
27e2fb84
LW		 3281 * root version must be called suidperl or sperlN.NNN. If regular perl
3282 * discovers that it has opened a setuid script, it calls suidperl with
3283 * the same argv that it had. If suidperl finds that the script it has
3284 * just opened is NOT setuid root, it sets the effective uid back to the
3285 * uid. We don't just make perl setuid root because that loses the
3286 * effective uid we had before invoking perl, if it was different from the
3287 * uid.
ae3f3efd
PS		 3288 * PSz 27 Feb 04
3289 * Description/comments above do not match current workings:
3290 * suidperl must be hardlinked to sperlN.NNN (that is what we exec);
3291 * suidperl called with script open and name changed to /dev/fd/N/X;
3292 * suidperl croaks if script is not setuid;
3293 * making perl setuid would be a huge security risk (and yes, that
3294 * would lose any euid we might have had).
13281fa4
LW		 3295 *
3296 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
3297 * be defined in suidperl only. suidperl must be setuid root. The
3298 * Configure script will set this up for you if you want it.
3299 */
a687059c 3300
13281fa4 3301#ifdef DOSUID
6e72f9df 3302 char *s, *s2;
a0d0e21e 3303
b28d0864 3304 if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0) /* normal stat is insecure */
cea2e8a9 3305 Perl_croak(aTHX_ "Can't stat script \"%s\"",PL_origfilename);
ae3f3efd 3306 if (PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
79072805 3307 I32 len;
2d8e6c8d 3308 STRLEN n_a;
13281fa4 3309
a687059c 3310#ifdef IAMSUID
ae3f3efd
PS		 3311 if (PL_fdscript < 0 || PL_suidscript != 1)
3312 Perl_croak(aTHX_ "Need (suid) fdscript in suidperl\n"); /* We already checked this */
3313 /* PSz 11 Nov 03
3314 * Since the script is opened by perl, not suidperl, some of these
3315 * checks are superfluous. Leaving them in probably does not lower
3316 * security(?!).
3317 */
3318 /* PSz 27 Feb 04
3319 * Do checks even for systems with no HAS_SETREUID.
3320 * We used to swap, then re-swap UIDs with
3321#ifdef HAS_SETREUID
3322 if (setreuid(PL_euid,PL_uid) < 0
3323 || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
3324 Perl_croak(aTHX_ "Can't swap uid and euid");
3325#endif
3326#ifdef HAS_SETREUID
3327 if (setreuid(PL_uid,PL_euid) < 0
3328 || PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid)
3329 Perl_croak(aTHX_ "Can't reswap uid and euid");
3330#endif
3331 */
3332
a687059c
LW		 3333 /* On this access check to make sure the directories are readable,
3334 * there is actually a small window that the user could use to make
3335 * filename point to an accessible directory. So there is a faint
3336 * chance that someone could execute a setuid script down in a
3337 * non-accessible directory. I don't know what to do about that.
3338 * But I don't think it's too important. The manual lies when
3339 * it says access() is useful in setuid programs.
ae3f3efd
PS		 3340 *
3341 * So, access() is pretty useless... but not harmful... do anyway.
a687059c 3342 */
e57400b1 3343 if (PerlLIO_access(CopFILE(PL_curcop),1)) { /*double check*/
ae3f3efd 3344 Perl_croak(aTHX_ "Can't access() script\n");
e57400b1 3345 }
ae3f3efd 3346
a687059c
LW		 3347 /* If we can swap euid and uid, then we can determine access rights
3348 * with a simple stat of the file, and then compare device and
3349 * inode to make sure we did stat() on the same file we opened.
3350 * Then we just have to make sure he or she can execute it.
ae3f3efd
PS		 3351 *
3352 * PSz 24 Feb 04
3353 * As the script is opened by perl, not suidperl, we do not need to
3354 * care much about access rights.
3355 *
3356 * The 'script changed' check is needed, or we can get lied to
3357 * about $0 with e.g.
3358 * suidperl /dev/fd/4//bin/x 4<setuidscript
3359 * Without HAS_SETREUID, is it safe to stat() as root?
3360 *
3361 * Are there any operating systems that pass /dev/fd/xxx for setuid
3362 * scripts, as suggested/described in perlsec(1)? Surely they do not
3363 * pass the script name as we do, so the "script changed" test would
3364 * fail for them... but we never get here with
3365 * SETUID_SCRIPTS_ARE_SECURE_NOW defined.
3366 *
3367 * This is one place where we must "lie" about return status: not
3368 * say if the stat() failed. We are doing this as root, and could
3369 * be tricked into reporting existence or not of files that the
3370 * "plain" user cannot even see.
a687059c
LW		 3371 */
3372 {
c623ac67 3373 Stat_t tmpstatbuf;
ae3f3efd
PS		 3374 if (PerlLIO_stat(CopFILE(PL_curcop),&tmpstatbuf) < 0 ||
3375 tmpstatbuf.st_dev != PL_statbuf.st_dev ||
b28d0864 3376 tmpstatbuf.st_ino != PL_statbuf.st_ino) {
ae3f3efd 3377 Perl_croak(aTHX_ "Setuid script changed\n");
a687059c 3378 }
ae3f3efd 3379
a687059c 3380 }
ae3f3efd
PS		 3381 if (!cando(S_IXUSR,FALSE,&PL_statbuf)) /* can real uid exec? */
3382 Perl_croak(aTHX_ "Real UID cannot exec script\n");
3383
3384 /* PSz 27 Feb 04
3385 * We used to do this check as the "plain" user (after swapping
3386 * UIDs). But the check for nosuid and noexec filesystem is needed,
3387 * and should be done even without HAS_SETREUID. (Maybe those
3388 * operating systems do not have such mount options anyway...)
3389 * Seems safe enough to do as root.
3390 */
3391#if !defined(NO_NOSUID_CHECK)
3392 if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp))) {
3393 Perl_croak(aTHX_ "Setuid script on nosuid or noexec filesystem\n");
3394 }
3395#endif
a687059c
LW		 3396#endif /* IAMSUID */
3397
e57400b1 3398 if (!S_ISREG(PL_statbuf.st_mode)) {
ae3f3efd 3399 Perl_croak(aTHX_ "Setuid script not plain file\n");
e57400b1 3400 }
b28d0864 3401 if (PL_statbuf.st_mode & S_IWOTH)
cea2e8a9 3402 Perl_croak(aTHX_ "Setuid/gid script is writable by world");
6b88bc9c 3403 PL_doswitches = FALSE; /* -s is insecure in suid */
ae3f3efd 3404 /* PSz 13 Nov 03 But -s was caught elsewhere ... so unsetting it here is useless(?!) */
57843af0 3405 CopLINE_inc(PL_curcop);
6b88bc9c 3406 if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch ||
2d8e6c8d 3407 strnNE(SvPV(PL_linestr,n_a),"#!",2) ) /* required even on Sys V */
cea2e8a9 3408 Perl_croak(aTHX_ "No #! line");
2d8e6c8d 3409 s = SvPV(PL_linestr,n_a)+2;
ae3f3efd
PS		 3410 /* PSz 27 Feb 04 */
3411 /* Sanity check on line length */
3412 if (strlen(s) < 1 || strlen(s) > 4000)
3413 Perl_croak(aTHX_ "Very long #! line");
3414 /* Allow more than a single space after #! */
3415 while (isSPACE(*s)) s++;
3416 /* Sanity check on buffer end */
3417 while ((*s) && !isSPACE(*s)) s++;
2d8e6c8d 3418 for (s2 = s; (s2 > SvPV(PL_linestr,n_a)+2 &&
6e72f9df 3419 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
ae3f3efd
PS		 3420 /* Sanity check on buffer start */
3421 if ( (s2-4 < SvPV(PL_linestr,n_a)+2 || strnNE(s2-4,"perl",4)) &&
3422 (s-9 < SvPV(PL_linestr,n_a)+2 || strnNE(s-9,"perl",4)) )
cea2e8a9 3423 Perl_croak(aTHX_ "Not a perl script");
a687059c 3424 while (*s == ' ' || *s == '\t') s++;
13281fa4
LW		 3425 /*
3426 * #! arg must be what we saw above. They can invoke it by
3427 * mentioning suidperl explicitly, but they may not add any strange
3428 * arguments beyond what #! says if they do invoke suidperl that way.
3429 */
ae3f3efd
PS		 3430 /*
3431 * The way validarg was set up, we rely on the kernel to start
3432 * scripts with argv[1] set to contain all #! line switches (the
3433 * whole line).
3434 */
3435 /*
3436 * Check that we got all the arguments listed in the #! line (not
3437 * just that there are no extraneous arguments). Might not matter
3438 * much, as switches from #! line seem to be acted upon (also), and
3439 * so may be checked and trapped in perl. But, security checks must
3440 * be done in suidperl and not deferred to perl. Note that suidperl
3441 * does not get around to parsing (and checking) the switches on
3442 * the #! line (but execs perl sooner).
3443 * Allow (require) a trailing newline (which may be of two
3444 * characters on some architectures?) (but no other trailing
3445 * whitespace).
3446 */
13281fa4
LW		 3447 len = strlen(validarg);
3448 if (strEQ(validarg," PHOOEY ") ||
ae3f3efd
PS		 3449 strnNE(s,validarg,len) || !isSPACE(s[len]) ||
3450 !(strlen(s) == len+1 || (strlen(s) == len+2 && isSPACE(s[len+1]))))
cea2e8a9 3451 Perl_croak(aTHX_ "Args must match #! line");
a687059c
LW		 3452
3453#ifndef IAMSUID
ae3f3efd
PS		 3454 if (PL_fdscript < 0 &&
3455 PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
b28d0864
NIS		 3456 PL_euid == PL_statbuf.st_uid)
3457 if (!PL_do_undump)
cea2e8a9 3458 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
11fb1898 3459FIX YOUR KERNEL, OR PUT A C WRAPPER AROUND THIS SCRIPT!\n");
a687059c 3460#endif /* IAMSUID */
13281fa4 3461
ae3f3efd
PS		 3462 if (PL_fdscript < 0 &&
3463 PL_euid) { /* oops, we're not the setuid root perl */
3464 /* PSz 18 Feb 04
3465 * When root runs a setuid script, we do not go through the same
3466 * steps of execing sperl and then perl with fd scripts, but
3467 * simply set up UIDs within the same perl invocation; so do
3468 * not have the same checks (on options, whatever) that we have
3469 * for plain users. No problem really: would have to be a script
3470 * that does not actually work for plain users; and if root is
3471 * foolish and can be persuaded to run such an unsafe script, he
3472 * might run also non-setuid ones, and deserves what he gets.
3473 *
3474 * Or, we might drop the PL_euid check above (and rely just on
3475 * PL_fdscript to avoid loops), and do the execs
3476 * even for root.
3477 */
13281fa4 3478#ifndef IAMSUID
ae3f3efd
PS		 3479 int which;
3480 /* PSz 11 Nov 03
3481 * Pass fd script to suidperl.
3482 * Exec suidperl, substituting fd script for scriptname.
3483 * Pass script name as "subdir" of fd, which perl will grok;
3484 * in fact will use that to distinguish this from "normal"
3485 * usage, see comments above.
3486 */
3487 PerlIO_rewind(PL_rsfp);
3488 PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0); /* just in case rewind didn't */
3489 /* PSz 27 Feb 04 Sanity checks on scriptname */
3490 if ((!scriptname) || (!*scriptname) ) {
3491 Perl_croak(aTHX_ "No setuid script name\n");
3492 }
3493 if (*scriptname == '-') {
3494 Perl_croak(aTHX_ "Setuid script name may not begin with dash\n");
3495 /* Or we might confuse it with an option when replacing
3496 * name in argument list, below (though we do pointer, not
3497 * string, comparisons).
3498 */
3499 }
3500 for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;
3501 if (!PL_origargv[which]) {
3502 Perl_croak(aTHX_ "Can't change argv to have fd script\n");
3503 }
3504 PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s",
3505 PerlIO_fileno(PL_rsfp), PL_origargv[which]));
3506#if defined(HAS_FCNTL) && defined(F_SETFD)
3507 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0); /* ensure no close-on-exec */
3508#endif
b35112e7 3509 PERL_FPU_PRE_EXEC
a7cb1f99 3510 PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, BIN_EXP,
273cf8d1
GS		 3511 (int)PERL_REVISION, (int)PERL_VERSION,
3512 (int)PERL_SUBVERSION), PL_origargv);
b35112e7 3513 PERL_FPU_POST_EXEC
ae3f3efd
PS		 3514#endif /* IAMSUID */
3515 Perl_croak(aTHX_ "Can't do setuid (cannot exec sperl)\n");
13281fa4
LW		 3516 }
3517
b28d0864 3518 if (PL_statbuf.st_mode & S_ISGID && PL_statbuf.st_gid != PL_egid) {
ae3f3efd
PS		 3519/* PSz 26 Feb 04
3520 * This seems back to front: we try HAS_SETEGID first; if not available
3521 * then try HAS_SETREGID; as a last chance we try HAS_SETRESGID. May be OK
3522 * in the sense that we only want to set EGID; but are there any machines
3523 * with either of the latter, but not the former? Same with UID, later.
3524 */
fe14fcc3 3525#ifdef HAS_SETEGID
b28d0864 3526 (void)setegid(PL_statbuf.st_gid);
a687059c 3527#else
fe14fcc3 3528#ifdef HAS_SETREGID
b28d0864 3529 (void)setregid((Gid_t)-1,PL_statbuf.st_gid);
85e6fe83
LW		 3530#else
3531#ifdef HAS_SETRESGID
b28d0864 3532 (void)setresgid((Gid_t)-1,PL_statbuf.st_gid,(Gid_t)-1);
a687059c 3533#else
b28d0864 3534 PerlProc_setgid(PL_statbuf.st_gid);
a687059c
LW		 3535#endif
3536#endif
85e6fe83 3537#endif
b28d0864 3538 if (PerlProc_getegid() != PL_statbuf.st_gid)
cea2e8a9 3539 Perl_croak(aTHX_ "Can't do setegid!\n");
83025b21 3540 }
b28d0864
NIS		 3541 if (PL_statbuf.st_mode & S_ISUID) {
3542 if (PL_statbuf.st_uid != PL_euid)
fe14fcc3 3543#ifdef HAS_SETEUID
b28d0864 3544 (void)seteuid(PL_statbuf.st_uid); /* all that for this */
a687059c 3545#else
fe14fcc3 3546#ifdef HAS_SETREUID
b28d0864 3547 (void)setreuid((Uid_t)-1,PL_statbuf.st_uid);
85e6fe83
LW		 3548#else
3549#ifdef HAS_SETRESUID
b28d0864 3550 (void)setresuid((Uid_t)-1,PL_statbuf.st_uid,(Uid_t)-1);
a687059c 3551#else
b28d0864 3552 PerlProc_setuid(PL_statbuf.st_uid);
a687059c
LW		 3553#endif
3554#endif
85e6fe83 3555#endif
b28d0864 3556 if (PerlProc_geteuid() != PL_statbuf.st_uid)
cea2e8a9 3557 Perl_croak(aTHX_ "Can't do seteuid!\n");
a687059c 3558 }
b28d0864 3559 else if (PL_uid) { /* oops, mustn't run as root */
fe14fcc3 3560#ifdef HAS_SETEUID