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
More const parms
[perl5.git] / perl.c
CommitLineData
a0d0e21e
LW		 1/* perl.c
2 *
4bb101f2 3 * Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999,
770526c1 4 * 2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others
a687059c 5 *
352d5a3a
LW		 6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
a687059c 8 *
8d063cd8
LW		 9 */
10
a0d0e21e
LW		 11/*
12 * "A ship then new they built for him/of mithril and of elven glass" --Bilbo
13 */
45d8adaa 14
166f8a29
DM		 15/* This file contains the top-level functions that are used to create, use
16 * and destroy a perl interpreter, plus the functions used by XS code to
17 * call back into perl. Note that it does not contain the actual main()
ddfa107c 18 * function of the interpreter; that can be found in perlmain.c
166f8a29
DM		 19 */
20
ae3f3efd
PS		 21/* PSz 12 Nov 03
22 *
23 * Be proud that perl(1) may proclaim:
24 * Setuid Perl scripts are safer than C programs ...
25 * Do not abandon (deprecate) suidperl. Do not advocate C wrappers.
26 *
27 * The flow was: perl starts, notices script is suid, execs suidperl with same
28 * arguments; suidperl opens script, checks many things, sets itself with
29 * right UID, execs perl with similar arguments but with script pre-opened on
30 * /dev/fd/xxx; perl checks script is as should be and does work. This was
31 * insecure: see perlsec(1) for many problems with this approach.
32 *
33 * The "correct" flow should be: perl starts, opens script and notices it is
34 * suid, checks many things, execs suidperl with similar arguments but with
35 * script on /dev/fd/xxx; suidperl checks script and /dev/fd/xxx object are
36 * same, checks arguments match #! line, sets itself with right UID, execs
37 * perl with same arguments; perl checks many things and does work.
38 *
39 * (Opening the script in perl instead of suidperl, we "lose" scripts that
40 * are readable to the target UID but not to the invoker. Where did
41 * unreadable scripts work anyway?)
42 *
43 * For now, suidperl and perl are pretty much the same large and cumbersome
44 * program, so suidperl can check its argument list (see comments elsewhere).
45 *
46 * References:
47 * Original bug report:
48 * http://bugs.perl.org/index.html?req=bug_id&bug_id=20010322.218
49 * http://rt.perl.org/rt2/Ticket/Display.html?id=6511
50 * Comments and discussion with Debian:
51 * http://bugs.debian.org/203426
52 * http://bugs.debian.org/220486
53 * Debian Security Advisory DSA 431-1 (does not fully fix problem):
54 * http://www.debian.org/security/2004/dsa-431
55 * CVE candidate:
56 * http://cve.mitre.org/cgi-bin/cvename.cgi?name=CAN-2003-0618
57 * Previous versions of this patch sent to perl5-porters:
58 * http://www.mail-archive.com/perl5-porters@perl.org/msg71953.html
59 * http://www.mail-archive.com/perl5-porters@perl.org/msg75245.html
60 * http://www.mail-archive.com/perl5-porters@perl.org/msg75563.html
61 * http://www.mail-archive.com/perl5-porters@perl.org/msg75635.html
62 *
63Paul Szabo - psz@maths.usyd.edu.au http://www.maths.usyd.edu.au:8000/u/psz/
64School of Mathematics and Statistics University of Sydney 2006 Australia
65 *
66 */
67/* PSz 13 Nov 03
68 * Use truthful, neat, specific error messages.
69 * Cannot always hide the truth; security must not depend on doing so.
70 */
71
72/* PSz 18 Feb 04
73 * Use global(?), thread-local fdscript for easier checks.
74 * (I do not understand how we could possibly get a thread race:
75 * do not all threads go through the same initialization? Or in
76 * fact, are not threads started only after we get the script and
77 * so know what to do? Oh well, make things super-safe...)
78 */
79
378cc40b 80#include "EXTERN.h"
864dbfa3 81#define PERL_IN_PERL_C
378cc40b 82#include "perl.h"
e3321bb0 83#include "patchlevel.h" /* for local_patches */
378cc40b 84
011f1a1a
JH		 85#ifdef NETWARE
86#include "nwutil.h"
87char *nw_get_sitelib(const char *pl);
88#endif
89
df5cef82 90/* XXX If this causes problems, set i_unistd=undef in the hint file. */
a0d0e21e
LW		 91#ifdef I_UNISTD
92#include <unistd.h>
93#endif
a0d0e21e 94
5311654c
JH		 95#ifdef __BEOS__
96# define HZ 1000000
97#endif
98
99#ifndef HZ
100# ifdef CLK_TCK
101# define HZ CLK_TCK
102# else
103# define HZ 60
104# endif
105#endif
106
7114a2d2 107#if !defined(STANDARD_C) && !defined(HAS_GETENV_PROTOTYPE) && !defined(PERL_MICRO)
20ce7b12 108char *getenv (char *); /* Usually in <stdlib.h> */
54310121 109#endif
110
acfe0abc 111static I32 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen);
0cb96387 112
a687059c
LW		 113#ifdef IAMSUID
114#ifndef DOSUID
115#define DOSUID
116#endif
ae3f3efd 117#endif /* IAMSUID */
378cc40b 118
a687059c
LW		 119#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
120#ifdef DOSUID
121#undef DOSUID
122#endif
123#endif
8d063cd8 124
e6827a76 125static void
daa7d858 126S_init_tls_and_interp(PerlInterpreter *my_perl)
e6827a76
NC		 127{
128 if (!PL_curinterp) {
129 PERL_SET_INTERP(my_perl);
3db8f154 130#if defined(USE_ITHREADS)
e6827a76
NC		 131 INIT_THREADS;
132 ALLOC_THREAD_KEY;
133 PERL_SET_THX(my_perl);
134 OP_REFCNT_INIT;
135 MUTEX_INIT(&PL_dollarzero_mutex);
06d86050 136# endif
e6827a76
NC		 137 }
138 else {
139 PERL_SET_THX(my_perl);
140 }
141}
06d86050 142
32e30700
GS		 143#ifdef PERL_IMPLICIT_SYS
144PerlInterpreter *
7766f137
GS		 145perl_alloc_using(struct IPerlMem* ipM, struct IPerlMem* ipMS,
146 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
32e30700
GS		 147 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
148 struct IPerlDir* ipD, struct IPerlSock* ipS,
149 struct IPerlProc* ipP)
150{
151 PerlInterpreter *my_perl;
32e30700
GS		 152 /* New() needs interpreter, so call malloc() instead */
153 my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
e6827a76 154 S_init_tls_and_interp(my_perl);
32e30700
GS		 155 Zero(my_perl, 1, PerlInterpreter);
156 PL_Mem = ipM;
7766f137
GS		 157 PL_MemShared = ipMS;
158 PL_MemParse = ipMP;
32e30700
GS		 159 PL_Env = ipE;
160 PL_StdIO = ipStd;
161 PL_LIO = ipLIO;
162 PL_Dir = ipD;
163 PL_Sock = ipS;
164 PL_Proc = ipP;
7766f137 165
32e30700
GS		 166 return my_perl;
167}
168#else
954c1994
GS		 169
170/*
ccfc67b7
JH		 171=head1 Embedding Functions
172
954c1994
GS		 173=for apidoc perl_alloc
174
175Allocates a new Perl interpreter. See L<perlembed>.
176
177=cut
178*/
179
93a17b20 180PerlInterpreter *
cea2e8a9 181perl_alloc(void)
79072805 182{
cea2e8a9 183 PerlInterpreter *my_perl;
79072805 184
54aff467 185 /* New() needs interpreter, so call malloc() instead */
e8ee3774 186 my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
ba869deb 187
e6827a76 188 S_init_tls_and_interp(my_perl);
e90e2364 189 return ZeroD(my_perl, 1, PerlInterpreter);
79072805 190}
32e30700 191#endif /* PERL_IMPLICIT_SYS */
79072805 192
954c1994
GS		 193/*
194=for apidoc perl_construct
195
196Initializes a new Perl interpreter. See L<perlembed>.
197
198=cut
199*/
200
79072805 201void
0cb96387 202perl_construct(pTHXx)
79072805 203{
8990e307 204#ifdef MULTIPLICITY
54aff467 205 init_interp();
ac27b0f5 206 PL_perl_destruct_level = 1;
54aff467
GS		 207#else
208 if (PL_perl_destruct_level > 0)
209 init_interp();
210#endif
33f46ff6 211 /* Init the real globals (and main thread)? */
3280af22 212 if (!PL_linestr) {
2aea9f8a
GS		 213 PL_curcop = &PL_compiling; /* needed by ckWARN, right away */
214
3280af22
NIS		 215 PL_linestr = NEWSV(65,79);
216 sv_upgrade(PL_linestr,SVt_PVIV);
79072805 217
3280af22 218 if (!SvREADONLY(&PL_sv_undef)) {
d689ffdd
JP		 219 /* set read-only and try to insure than we wont see REFCNT==0
220 very often */
221
3280af22
NIS		 222 SvREADONLY_on(&PL_sv_undef);
223 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
79072805 224
3280af22 225 sv_setpv(&PL_sv_no,PL_No);
0309f36e
NC		 226 /* value lookup in void context - happens to have the side effect
227 of caching the numeric forms. */
228 SvIV(&PL_sv_no);
3280af22
NIS		 229 SvNV(&PL_sv_no);
230 SvREADONLY_on(&PL_sv_no);
231 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
79072805 232
3280af22 233 sv_setpv(&PL_sv_yes,PL_Yes);
0309f36e 234 SvIV(&PL_sv_yes);
3280af22
NIS		 235 SvNV(&PL_sv_yes);
236 SvREADONLY_on(&PL_sv_yes);
237 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
7996736c
MHM		 238
239 SvREADONLY_on(&PL_sv_placeholder);
240 SvREFCNT(&PL_sv_placeholder) = (~(U32)0)/2;
6e72f9df 241 }
79072805 242
cea2e8a9 243 PL_sighandlerp = Perl_sighandler;
3280af22 244 PL_pidstatus = newHV();
79072805
LW		 245 }
246
8bfdd7d9 247 PL_rs = newSVpvn("\n", 1);
dc92893f 248
cea2e8a9 249 init_stacks();
79072805 250
748a9306 251 init_ids();
3280af22 252 PL_lex_state = LEX_NOTPARSING;
a5f75d66 253
312caa8e 254 JMPENV_BOOTSTRAP;
f86702cc 255 STATUS_ALL_SUCCESS;
256
0672f40e 257 init_i18nl10n(1);
36477c24 258 SET_NUMERIC_STANDARD();
0b5b802d 259
ab821d7f 260#if defined(LOCAL_PATCH_COUNT)
3280af22 261 PL_localpatches = local_patches; /* For possible -v */
ab821d7f 262#endif
263
52853b95
GS		 264#ifdef HAVE_INTERP_INTERN
265 sys_intern_init();
266#endif
267
3a1ee7e8 268 PerlIO_init(aTHX); /* Hook to IO system */
760ac839 269
3280af22
NIS		 270 PL_fdpid = newAV(); /* for remembering popen pids by fd */
271 PL_modglobal = newHV(); /* pointers to per-interpreter module globals */
24944567 272 PL_errors = newSVpvn("",0);
48c6b404 273 sv_setpvn(PERL_DEBUG_PAD(0), "", 0); /* For regex debugging. */
1f483ca1
JH		 274 sv_setpvn(PERL_DEBUG_PAD(1), "", 0); /* ext/re needs these */
275 sv_setpvn(PERL_DEBUG_PAD(2), "", 0); /* even without DEBUGGING. */
1fcf4c12 276#ifdef USE_ITHREADS
13137afc
AB		 277 PL_regex_padav = newAV();
278 av_push(PL_regex_padav,(SV*)newAV()); /* First entry is an array of empty elements */
279 PL_regex_pad = AvARRAY(PL_regex_padav);
1fcf4c12 280#endif
e5dd39fc 281#ifdef USE_REENTRANT_API
59bd0823 282 Perl_reentrant_init(aTHX);
e5dd39fc 283#endif
3d47000e
AB		 284
285 /* Note that strtab is a rather special HV. Assumptions are made
286 about not iterating on it, and not adding tie magic to it.
287 It is properly deallocated in perl_destruct() */
288 PL_strtab = newHV();
289
3d47000e
AB		 290 HvSHAREKEYS_off(PL_strtab); /* mandatory */
291 hv_ksplit(PL_strtab, 512);
292
0631ea03
AB		 293#if defined(__DYNAMIC__) && (defined(NeXT) || defined(__NeXT__))
294 _dyld_lookup_and_bind
295 ("__environ", (unsigned long *) &environ_pointer, NULL);
296#endif /* environ */
297
2f42fcb0
JH		 298#ifndef PERL_MICRO
299# ifdef USE_ENVIRON_ARRAY
0631ea03 300 PL_origenviron = environ;
2f42fcb0 301# endif
0631ea03
AB		 302#endif
303
5311654c 304 /* Use sysconf(_SC_CLK_TCK) if available, if not
dbc1d986
IW		 305 * available or if the sysconf() fails, use the HZ.
306 * BeOS has those, but returns the wrong value. */
307#if defined(HAS_SYSCONF) && defined(_SC_CLK_TCK) && !defined(__BEOS__)
5311654c
JH		 308 PL_clocktick = sysconf(_SC_CLK_TCK);
309 if (PL_clocktick <= 0)
310#endif
311 PL_clocktick = HZ;
312
081fc587
AB		 313 PL_stashcache = newHV();
314
d7aa5382
JP		 315 PL_patchlevel = newSVpv(
316 Perl_form(aTHX_ "%d.%d.%d",
317 (int)PERL_REVISION,
318 (int)PERL_VERSION,
319 (int)PERL_SUBVERSION ), 0
320 );
321
8990e307 322 ENTER;
79072805
LW		 323}
324
954c1994 325/*
62375a60
NIS		 326=for apidoc nothreadhook
327
328Stub that provides thread hook for perl_destruct when there are
329no threads.
330
331=cut
332*/
333
334int
4e9e3734 335Perl_nothreadhook(pTHX)
62375a60
NIS		 336{
337 return 0;
338}
339
340/*
954c1994
GS		 341=for apidoc perl_destruct
342
343Shuts down a Perl interpreter. See L<perlembed>.
344
345=cut
346*/
347
31d77e54 348int
0cb96387 349perl_destruct(pTHXx)
79072805 350{
7c474504 351 volatile int destruct_level; /* 0=none, 1=full, 2=full with checks */
a0d0e21e 352 HV *hv;
8990e307 353
7766f137
GS		 354 /* wait for all pseudo-forked children to finish */
355 PERL_WAIT_FOR_CHILDREN;
356
3280af22 357 destruct_level = PL_perl_destruct_level;
4633a7c4
LW		 358#ifdef DEBUGGING
359 {
360 char *s;
155aba94 361 if ((s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL"))) {
5f05dabc 362 int i = atoi(s);
363 if (destruct_level < i)
364 destruct_level = i;
365 }
4633a7c4
LW		 366 }
367#endif
368
31d77e54
AB		 369
370 if(PL_exit_flags & PERL_EXIT_DESTRUCT_END) {
f3faeb53
AB		 371 dJMPENV;
372 int x = 0;
373
374 JMPENV_PUSH(x);
375 if (PL_endav && !PL_minus_c)
376 call_list(PL_scopestack_ix, PL_endav);
377 JMPENV_POP;
26f423df 378 }
f3faeb53 379 LEAVE;
a0d0e21e
LW		 380 FREETMPS;
381
e00b64d4 382 /* Need to flush since END blocks can produce output */
f13a2bc0 383 my_fflush_all();
e00b64d4 384
62375a60
NIS		 385 if (CALL_FPTR(PL_threadhook)(aTHX)) {
386 /* Threads hook has vetoed further cleanup */
b47cad08 387 return STATUS_NATIVE_EXPORT;
62375a60
NIS		 388 }
389
ff0cee69 390 /* We must account for everything. */
391
392 /* Destroy the main CV and syntax tree */
3280af22 393 if (PL_main_root) {
4e380990
DM		 394 /* ensure comppad/curpad to refer to main's pad */
395 if (CvPADLIST(PL_main_cv)) {
396 PAD_SET_CUR_NOSAVE(CvPADLIST(PL_main_cv), 1);
397 }
3280af22
NIS		 398 op_free(PL_main_root);
399 PL_main_root = Nullop;
a0d0e21e 400 }
3280af22
NIS		 401 PL_curcop = &PL_compiling;
402 PL_main_start = Nullop;
403 SvREFCNT_dec(PL_main_cv);
404 PL_main_cv = Nullcv;
24d3c518 405 PL_dirty = TRUE;
ff0cee69 406
13621cfb
NIS		 407 /* Tell PerlIO we are about to tear things apart in case
408 we have layers which are using resources that should
409 be cleaned up now.
410 */
411
412 PerlIO_destruct(aTHX);
413
3280af22 414 if (PL_sv_objcount) {
a0d0e21e
LW		 415 /*
416 * Try to destruct global references. We do this first so that the
417 * destructors and destructees still exist. Some sv's might remain.
418 * Non-referenced objects are on their own.
419 */
a0d0e21e 420 sv_clean_objs();
bf9cdc68 421 PL_sv_objcount = 0;
8990e307
LW		 422 }
423
5cd24f17 424 /* unhook hooks which will soon be, or use, destroyed data */
3280af22
NIS		 425 SvREFCNT_dec(PL_warnhook);
426 PL_warnhook = Nullsv;
427 SvREFCNT_dec(PL_diehook);
428 PL_diehook = Nullsv;
5cd24f17 429
4b556e6c 430 /* call exit list functions */
3280af22 431 while (PL_exitlistlen-- > 0)
acfe0abc 432 PL_exitlist[PL_exitlistlen].fn(aTHX_ PL_exitlist[PL_exitlistlen].ptr);
4b556e6c 433
3280af22 434 Safefree(PL_exitlist);
4b556e6c 435
1c4916e5
CB		 436 PL_exitlist = NULL;
437 PL_exitlistlen = 0;
438
a0d0e21e 439 if (destruct_level == 0){
8990e307 440
a0d0e21e 441 DEBUG_P(debprofdump());
ac27b0f5 442
56a2bab7
NIS		 443#if defined(PERLIO_LAYERS)
444 /* No more IO - including error messages ! */
445 PerlIO_cleanup(aTHX);
446#endif
447
a0d0e21e 448 /* The exit() function will do everything that needs doing. */
b47cad08 449 return STATUS_NATIVE_EXPORT;
a0d0e21e 450 }
5dd60ef7 451
551a8b83 452 /* jettison our possibly duplicated environment */
4b647fb0
DM		 453 /* if PERL_USE_SAFE_PUTENV is defined environ will not have been copied
454 * so we certainly shouldn't free it here
455 */
2f42fcb0 456#ifndef PERL_MICRO
4b647fb0 457#if defined(USE_ENVIRON_ARRAY) && !defined(PERL_USE_SAFE_PUTENV)
50acdf95 458 if (environ != PL_origenviron && !PL_use_safe_putenv
4efc5df6
GS		 459#ifdef USE_ITHREADS
460 /* only main thread can free environ[0] contents */
461 && PL_curinterp == aTHX
462#endif
463 )
464 {
551a8b83
JH		 465 I32 i;
466
467 for (i = 0; environ[i]; i++)
4b420006 468 safesysfree(environ[i]);
0631ea03 469
4b420006
JH		 470 /* Must use safesysfree() when working with environ. */
471 safesysfree(environ);
551a8b83
JH		 472
473 environ = PL_origenviron;
474 }
475#endif
2f42fcb0 476#endif /* !PERL_MICRO */
551a8b83 477
804ffa60
DM		 478 /* reset so print() ends up where we expect */
479 setdefout(Nullgv);
480
5f8cb046
DM		 481#ifdef USE_ITHREADS
482 /* the syntax tree is shared between clones
483 * so op_free(PL_main_root) only ReREFCNT_dec's
484 * REGEXPs in the parent interpreter
485 * we need to manually ReREFCNT_dec for the clones
486 */
487 {
488 I32 i = AvFILLp(PL_regex_padav) + 1;
489 SV **ary = AvARRAY(PL_regex_padav);
490
491 while (i) {
35061a7e 492 SV *resv = ary[--i];
ba89bb6e 493 REGEXP *re = INT2PTR(REGEXP *,SvIVX(resv));
35061a7e
DM		 494
495 if (SvFLAGS(resv) & SVf_BREAK) {
577e12cc 496 /* this is PL_reg_curpm, already freed
35061a7e
DM		 497 * flag is set in regexec.c:S_regtry
498 */
499 SvFLAGS(resv) &= ~SVf_BREAK;
3a1ee7e8 500 }
1cc8b4c5
AB		 501 else if(SvREPADTMP(resv)) {
502 SvREPADTMP_off(resv);
503 }
35061a7e 504 else {
5f8cb046
DM		 505 ReREFCNT_dec(re);
506 }
507 }
508 }
509 SvREFCNT_dec(PL_regex_padav);
510 PL_regex_padav = Nullav;
511 PL_regex_pad = NULL;
512#endif
513
081fc587
AB		 514 SvREFCNT_dec((SV*) PL_stashcache);
515 PL_stashcache = NULL;
516
5f05dabc 517 /* loosen bonds of global variables */
518
3280af22
NIS		 519 if(PL_rsfp) {
520 (void)PerlIO_close(PL_rsfp);
521 PL_rsfp = Nullfp;
8ebc5c01 522 }
523
524 /* Filters for program text */
3280af22
NIS		 525 SvREFCNT_dec(PL_rsfp_filters);
526 PL_rsfp_filters = Nullav;
8ebc5c01 527
528 /* switches */
3280af22
NIS		 529 PL_preprocess = FALSE;
530 PL_minus_n = FALSE;
531 PL_minus_p = FALSE;
532 PL_minus_l = FALSE;
533 PL_minus_a = FALSE;
534 PL_minus_F = FALSE;
535 PL_doswitches = FALSE;
599cee73 536 PL_dowarn = G_WARN_OFF;
3280af22
NIS		 537 PL_doextract = FALSE;
538 PL_sawampersand = FALSE; /* must save all match strings */
3280af22
NIS		 539 PL_unsafe = FALSE;
540
541 Safefree(PL_inplace);
542 PL_inplace = Nullch;
a7cb1f99 543 SvREFCNT_dec(PL_patchlevel);
3280af22
NIS		 544
545 if (PL_e_script) {
546 SvREFCNT_dec(PL_e_script);
547 PL_e_script = Nullsv;
8ebc5c01 548 }
549
bf9cdc68
RG		 550 PL_perldb = 0;
551
8ebc5c01 552 /* magical thingies */
553
7889fe52
NIS		 554 SvREFCNT_dec(PL_ofs_sv); /* $, */
555 PL_ofs_sv = Nullsv;
5f05dabc 556
7889fe52
NIS		 557 SvREFCNT_dec(PL_ors_sv); /* $\ */
558 PL_ors_sv = Nullsv;
8ebc5c01 559
3280af22
NIS		 560 SvREFCNT_dec(PL_rs); /* $/ */
561 PL_rs = Nullsv;
dc92893f 562
d33b2eba
GS		 563 PL_multiline = 0; /* $* */
564 Safefree(PL_osname); /* $^O */
565 PL_osname = Nullch;
5f05dabc 566
3280af22
NIS		 567 SvREFCNT_dec(PL_statname);
568 PL_statname = Nullsv;
569 PL_statgv = Nullgv;
5f05dabc 570
8ebc5c01 571 /* defgv, aka *_ should be taken care of elsewhere */
572
8ebc5c01 573 /* clean up after study() */
3280af22
NIS		 574 SvREFCNT_dec(PL_lastscream);
575 PL_lastscream = Nullsv;
576 Safefree(PL_screamfirst);
577 PL_screamfirst = 0;
578 Safefree(PL_screamnext);
579 PL_screamnext = 0;
8ebc5c01 580
7d5ea4e7
GS		 581 /* float buffer */
582 Safefree(PL_efloatbuf);
583 PL_efloatbuf = Nullch;
584 PL_efloatsize = 0;
585
8ebc5c01 586 /* startup and shutdown function lists */
3280af22 587 SvREFCNT_dec(PL_beginav);
5a837c8f 588 SvREFCNT_dec(PL_beginav_save);
3280af22 589 SvREFCNT_dec(PL_endav);
7d30b5c4 590 SvREFCNT_dec(PL_checkav);
ece599bd 591 SvREFCNT_dec(PL_checkav_save);
3280af22
NIS		 592 SvREFCNT_dec(PL_initav);
593 PL_beginav = Nullav;
5a837c8f 594 PL_beginav_save = Nullav;
3280af22 595 PL_endav = Nullav;
7d30b5c4 596 PL_checkav = Nullav;
ece599bd 597 PL_checkav_save = Nullav;
3280af22 598 PL_initav = Nullav;
5618dfe8 599
8ebc5c01 600 /* shortcuts just get cleared */
3280af22 601 PL_envgv = Nullgv;
3280af22
NIS		 602 PL_incgv = Nullgv;
603 PL_hintgv = Nullgv;
604 PL_errgv = Nullgv;
605 PL_argvgv = Nullgv;
606 PL_argvoutgv = Nullgv;
607 PL_stdingv = Nullgv;
bf49b057 608 PL_stderrgv = Nullgv;
3280af22
NIS		 609 PL_last_in_gv = Nullgv;
610 PL_replgv = Nullgv;
bf9cdc68
RG		 611 PL_DBgv = Nullgv;
612 PL_DBline = Nullgv;
613 PL_DBsub = Nullgv;
614 PL_DBsingle = Nullsv;
615 PL_DBtrace = Nullsv;
616 PL_DBsignal = Nullsv;
617 PL_DBassertion = Nullsv;
618 PL_DBcv = Nullcv;
619 PL_dbargs = Nullav;
5c831c24 620 PL_debstash = Nullhv;
8ebc5c01 621
7a1c5554
GS		 622 SvREFCNT_dec(PL_argvout_stack);
623 PL_argvout_stack = Nullav;
8ebc5c01 624
5c831c24
GS		 625 SvREFCNT_dec(PL_modglobal);
626 PL_modglobal = Nullhv;
627 SvREFCNT_dec(PL_preambleav);
628 PL_preambleav = Nullav;
629 SvREFCNT_dec(PL_subname);
630 PL_subname = Nullsv;
631 SvREFCNT_dec(PL_linestr);
632 PL_linestr = Nullsv;
633 SvREFCNT_dec(PL_pidstatus);
634 PL_pidstatus = Nullhv;
635 SvREFCNT_dec(PL_toptarget);
636 PL_toptarget = Nullsv;
637 SvREFCNT_dec(PL_bodytarget);
638 PL_bodytarget = Nullsv;
639 PL_formtarget = Nullsv;
640
d33b2eba 641 /* free locale stuff */
b9582b6a 642#ifdef USE_LOCALE_COLLATE
d33b2eba
GS		 643 Safefree(PL_collation_name);
644 PL_collation_name = Nullch;
b9582b6a 645#endif
d33b2eba 646
b9582b6a 647#ifdef USE_LOCALE_NUMERIC
d33b2eba
GS		 648 Safefree(PL_numeric_name);
649 PL_numeric_name = Nullch;
a453c169 650 SvREFCNT_dec(PL_numeric_radix_sv);
bf9cdc68 651 PL_numeric_radix_sv = Nullsv;
b9582b6a 652#endif
d33b2eba 653
5c831c24
GS		 654 /* clear utf8 character classes */
655 SvREFCNT_dec(PL_utf8_alnum);
656 SvREFCNT_dec(PL_utf8_alnumc);
657 SvREFCNT_dec(PL_utf8_ascii);
658 SvREFCNT_dec(PL_utf8_alpha);
659 SvREFCNT_dec(PL_utf8_space);
660 SvREFCNT_dec(PL_utf8_cntrl);
661 SvREFCNT_dec(PL_utf8_graph);
662 SvREFCNT_dec(PL_utf8_digit);
663 SvREFCNT_dec(PL_utf8_upper);
664 SvREFCNT_dec(PL_utf8_lower);
665 SvREFCNT_dec(PL_utf8_print);
666 SvREFCNT_dec(PL_utf8_punct);
667 SvREFCNT_dec(PL_utf8_xdigit);
668 SvREFCNT_dec(PL_utf8_mark);
669 SvREFCNT_dec(PL_utf8_toupper);
4dbdbdc2 670 SvREFCNT_dec(PL_utf8_totitle);
5c831c24 671 SvREFCNT_dec(PL_utf8_tolower);
b4e400f9 672 SvREFCNT_dec(PL_utf8_tofold);
82686b01
JH		 673 SvREFCNT_dec(PL_utf8_idstart);
674 SvREFCNT_dec(PL_utf8_idcont);
5c831c24
GS		 675 PL_utf8_alnum = Nullsv;
676 PL_utf8_alnumc = Nullsv;
677 PL_utf8_ascii = Nullsv;
678 PL_utf8_alpha = Nullsv;
679 PL_utf8_space = Nullsv;
680 PL_utf8_cntrl = Nullsv;
681 PL_utf8_graph = Nullsv;
682 PL_utf8_digit = Nullsv;
683 PL_utf8_upper = Nullsv;
684 PL_utf8_lower = Nullsv;
685 PL_utf8_print = Nullsv;
686 PL_utf8_punct = Nullsv;
687 PL_utf8_xdigit = Nullsv;
688 PL_utf8_mark = Nullsv;
689 PL_utf8_toupper = Nullsv;
690 PL_utf8_totitle = Nullsv;
691 PL_utf8_tolower = Nullsv;
b4e400f9 692 PL_utf8_tofold = Nullsv;
82686b01
JH		 693 PL_utf8_idstart = Nullsv;
694 PL_utf8_idcont = Nullsv;
5c831c24 695
971a9dd3
GS		 696 if (!specialWARN(PL_compiling.cop_warnings))
697 SvREFCNT_dec(PL_compiling.cop_warnings);
5c831c24 698 PL_compiling.cop_warnings = Nullsv;
ac27b0f5
NIS		 699 if (!specialCopIO(PL_compiling.cop_io))
700 SvREFCNT_dec(PL_compiling.cop_io);
701 PL_compiling.cop_io = Nullsv;
05ec9bb3
NIS		 702 CopFILE_free(&PL_compiling);
703 CopSTASH_free(&PL_compiling);
5c831c24 704
a0d0e21e 705 /* Prepare to destruct main symbol table. */
5f05dabc 706
3280af22
NIS		 707 hv = PL_defstash;
708 PL_defstash = 0;
a0d0e21e 709 SvREFCNT_dec(hv);
5c831c24
GS		 710 SvREFCNT_dec(PL_curstname);
711 PL_curstname = Nullsv;
a0d0e21e 712
5a844595
GS		 713 /* clear queued errors */
714 SvREFCNT_dec(PL_errors);
715 PL_errors = Nullsv;
716
a0d0e21e 717 FREETMPS;
0453d815 718 if (destruct_level >= 2 && ckWARN_d(WARN_INTERNAL)) {
3280af22 719 if (PL_scopestack_ix != 0)
9014280d 720 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
0453d815 721 "Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
3280af22
NIS		 722 (long)PL_scopestack_ix);
723 if (PL_savestack_ix != 0)
9014280d 724 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
0453d815 725 "Unbalanced saves: %ld more saves than restores\n",
3280af22
NIS		 726 (long)PL_savestack_ix);
727 if (PL_tmps_floor != -1)
9014280d 728 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced tmps: %ld more allocs than frees\n",
3280af22 729 (long)PL_tmps_floor + 1);
a0d0e21e 730 if (cxstack_ix != -1)
9014280d 731 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced context: %ld more PUSHes than POPs\n",
ff0cee69 732 (long)cxstack_ix + 1);
a0d0e21e 733 }
8990e307
LW		 734
735 /* Now absolutely destruct everything, somehow or other, loops or no. */
d33b2eba 736 SvFLAGS(PL_fdpid) |= SVTYPEMASK; /* don't clean out pid table now */
3280af22 737 SvFLAGS(PL_strtab) |= SVTYPEMASK; /* don't clean out strtab now */
5226ed68
JH		 738
739 /* the 2 is for PL_fdpid and PL_strtab */
740 while (PL_sv_count > 2 && sv_clean_all())
741 ;
742
d33b2eba
GS		 743 SvFLAGS(PL_fdpid) &= ~SVTYPEMASK;
744 SvFLAGS(PL_fdpid) |= SVt_PVAV;
3280af22
NIS		 745 SvFLAGS(PL_strtab) &= ~SVTYPEMASK;
746 SvFLAGS(PL_strtab) |= SVt_PVHV;
d33b2eba 747
d4777f27
GS		 748 AvREAL_off(PL_fdpid); /* no surviving entries */
749 SvREFCNT_dec(PL_fdpid); /* needed in io_close() */
d33b2eba
GS		 750 PL_fdpid = Nullav;
751
6c644e78
GS		 752#ifdef HAVE_INTERP_INTERN
753 sys_intern_clear();
754#endif
755
6e72f9df 756 /* Destruct the global string table. */
757 {
758 /* Yell and reset the HeVAL() slots that are still holding refcounts,
759 * so that sv_free() won't fail on them.
760 */
761 I32 riter;
762 I32 max;
763 HE *hent;
764 HE **array;
765
766 riter = 0;
3280af22
NIS		 767 max = HvMAX(PL_strtab);
768 array = HvARRAY(PL_strtab);
6e72f9df 769 hent = array[0];
770 for (;;) {
0453d815 771 if (hent && ckWARN_d(WARN_INTERNAL)) {
9014280d 772 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
0453d815 773 "Unbalanced string table refcount: (%d) for \"%s\"",
6e72f9df 774 HeVAL(hent) - Nullsv, HeKEY(hent));
775 HeVAL(hent) = Nullsv;
776 hent = HeNEXT(hent);
777 }
778 if (!hent) {
779 if (++riter > max)
780 break;
781 hent = array[riter];
782 }
783 }
784 }
3280af22 785 SvREFCNT_dec(PL_strtab);
6e72f9df 786
e652bb2f 787#ifdef USE_ITHREADS
a0739874
DM		 788 /* free the pointer table used for cloning */
789 ptr_table_free(PL_ptr_table);
bf9cdc68 790 PL_ptr_table = (PTR_TBL_t*)NULL;
53186e96 791#endif
a0739874 792
d33b2eba
GS		 793 /* free special SVs */
794
795 SvREFCNT(&PL_sv_yes) = 0;
796 sv_clear(&PL_sv_yes);
797 SvANY(&PL_sv_yes) = NULL;
4c5e2b0d 798 SvFLAGS(&PL_sv_yes) = 0;
d33b2eba
GS		 799
800 SvREFCNT(&PL_sv_no) = 0;
801 sv_clear(&PL_sv_no);
802 SvANY(&PL_sv_no) = NULL;
4c5e2b0d 803 SvFLAGS(&PL_sv_no) = 0;
01724ea0 804
9f375a43
DM		 805 {
806 int i;
807 for (i=0; i<=2; i++) {
808 SvREFCNT(PERL_DEBUG_PAD(i)) = 0;
809 sv_clear(PERL_DEBUG_PAD(i));
810 SvANY(PERL_DEBUG_PAD(i)) = NULL;
811 SvFLAGS(PERL_DEBUG_PAD(i)) = 0;
812 }
813 }
814
0453d815 815 if (PL_sv_count != 0 && ckWARN_d(WARN_INTERNAL))
9014280d 816 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Scalars leaked: %ld\n", (long)PL_sv_count);
6e72f9df 817
eba0f806
DM		 818#ifdef DEBUG_LEAKING_SCALARS
819 if (PL_sv_count != 0) {
820 SV* sva;
821 SV* sv;
822 register SV* svend;
823
824 for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
825 svend = &sva[SvREFCNT(sva)];
826 for (sv = sva + 1; sv < svend; ++sv) {
827 if (SvTYPE(sv) != SVTYPEMASK) {
a548cda8
DM		 828 PerlIO_printf(Perl_debug_log, "leaked: sv=0x%p"
829 " flags=0x08%"UVxf
830 " refcnt=%"UVuf pTHX__FORMAT "\n",
831 sv, sv->sv_flags, sv->sv_refcnt pTHX__VALUE);
eba0f806
DM		 832 }
833 }
834 }
835 }
836#endif
bf9cdc68 837 PL_sv_count = 0;
eba0f806
DM		 838
839
56a2bab7 840#if defined(PERLIO_LAYERS)
3a1ee7e8
NIS		 841 /* No more IO - including error messages ! */
842 PerlIO_cleanup(aTHX);
843#endif
844
9f4bd222
NIS		 845 /* sv_undef needs to stay immortal until after PerlIO_cleanup
846 as currently layers use it rather than Nullsv as a marker
847 for no arg - and will try and SvREFCNT_dec it.
848 */
849 SvREFCNT(&PL_sv_undef) = 0;
850 SvREADONLY_off(&PL_sv_undef);
851
3280af22 852 Safefree(PL_origfilename);
bf9cdc68 853 PL_origfilename = Nullch;
3280af22 854 Safefree(PL_reg_start_tmp);
bf9cdc68
RG		 855 PL_reg_start_tmp = (char**)NULL;
856 PL_reg_start_tmpl = 0;
5c5e4c24
IZ		 857 if (PL_reg_curpm)
858 Safefree(PL_reg_curpm);
82ba1be6 859 Safefree(PL_reg_poscache);
dd28f7bb 860 free_tied_hv_pool();
3280af22 861 Safefree(PL_op_mask);
cf36064f 862 Safefree(PL_psig_ptr);
bf9cdc68 863 PL_psig_ptr = (SV**)NULL;
cf36064f 864 Safefree(PL_psig_name);
bf9cdc68 865 PL_psig_name = (SV**)NULL;
2c2666fc 866 Safefree(PL_bitcount);
bf9cdc68 867 PL_bitcount = Nullch;
ce08f86c 868 Safefree(PL_psig_pend);
bf9cdc68
RG		 869 PL_psig_pend = (int*)NULL;
870 PL_formfeed = Nullsv;
871 Safefree(PL_ofmt);
872 PL_ofmt = Nullch;
6e72f9df 873 nuke_stacks();
bf9cdc68
RG		 874 PL_tainting = FALSE;
875 PL_taint_warn = FALSE;
3280af22 876 PL_hints = 0; /* Reset hints. Should hints be per-interpreter ? */
bf9cdc68 877 PL_debug = 0;
ac27b0f5 878
a0d0e21e 879 DEBUG_P(debprofdump());
d33b2eba 880
e5dd39fc 881#ifdef USE_REENTRANT_API
10bc17b6 882 Perl_reentrant_free(aTHX);
e5dd39fc
AB		 883#endif
884
612f20c3
GS		 885 sv_free_arenas();
886
fc36a67e 887 /* As the absolutely last thing, free the non-arena SV for mess() */
888
3280af22 889 if (PL_mess_sv) {
9c63abab
GS		 890 /* it could have accumulated taint magic */
891 if (SvTYPE(PL_mess_sv) >= SVt_PVMG) {
892 MAGIC* mg;
893 MAGIC* moremagic;
894 for (mg = SvMAGIC(PL_mess_sv); mg; mg = moremagic) {
895 moremagic = mg->mg_moremagic;
14befaf4
DM		 896 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global
897 && mg->mg_len >= 0)
9c63abab
GS		 898 Safefree(mg->mg_ptr);
899 Safefree(mg);
900 }
901 }
fc36a67e 902 /* we know that type >= SVt_PV */
0c34ef67 903 SvOOK_off(PL_mess_sv);
3280af22
NIS		 904 Safefree(SvPVX(PL_mess_sv));
905 Safefree(SvANY(PL_mess_sv));
906 Safefree(PL_mess_sv);
907 PL_mess_sv = Nullsv;
fc36a67e 908 }
31d77e54 909 return STATUS_NATIVE_EXPORT;
79072805
LW		 910}
911
954c1994
GS		 912/*
913=for apidoc perl_free
914
915Releases a Perl interpreter. See L<perlembed>.
916
917=cut
918*/
919
79072805 920void
0cb96387 921perl_free(pTHXx)
79072805 922{
acfe0abc 923#if defined(WIN32) || defined(NETWARE)
ce3e5b80 924# if defined(PERL_IMPLICIT_SYS)
acfe0abc
GS		 925# ifdef NETWARE
926 void *host = nw_internal_host;
927# else
928 void *host = w32_internal_host;
929# endif
ce3e5b80 930 PerlMem_free(aTHXx);
acfe0abc 931# ifdef NETWARE
011f1a1a 932 nw_delete_internal_host(host);
acfe0abc
GS		 933# else
934 win32_delete_internal_host(host);
935# endif
1c0ca838
GS		 936# else
937 PerlMem_free(aTHXx);
938# endif
acfe0abc
GS		 939#else
940 PerlMem_free(aTHXx);
76e3520e 941#endif
79072805
LW		 942}
943
aebd1ac7
GA		 944#if defined(USE_5005THREADS) || defined(USE_ITHREADS)
945/* provide destructors to clean up the thread key when libperl is unloaded */
946#ifndef WIN32 /* handled during DLL_PROCESS_DETACH in win32/perllib.c */
947
948#if defined(__hpux) && !defined(__GNUC__)
949#pragma fini "perl_fini"
950#endif
951
952#if defined(__GNUC__) && defined(__attribute__)
953/* want to make sure __attribute__ works here even
954 * for -Dd_attribut=undef builds.
955 */
956#undef __attribute__
957#endif
958
959static void __attribute__((destructor))
960perl_fini()
961{
962 if (PL_curinterp)
963 FREE_THREAD_KEY;
964}
965
966#endif /* WIN32 */
967#endif /* THREADS */
968
4b556e6c 969void
864dbfa3 970Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr)
4b556e6c 971{
3280af22
NIS		 972 Renew(PL_exitlist, PL_exitlistlen+1, PerlExitListEntry);
973 PL_exitlist[PL_exitlistlen].fn = fn;
974 PL_exitlist[PL_exitlistlen].ptr = ptr;
975 ++PL_exitlistlen;
4b556e6c
JD		 976}
977
56cf6df8
RGS		 978#ifdef HAS_PROCSELFEXE
979/* This is a function so that we don't hold on to MAXPATHLEN
980 bytes of stack longer than necessary
981 */
982STATIC void
983S_procself_val(pTHX_ SV *sv, char *arg0)
984{
985 char buf[MAXPATHLEN];
986 int len = readlink(PROCSELFEXE_PATH, buf, sizeof(buf) - 1);
987
988 /* On Playstation2 Linux V1.0 (kernel 2.2.1) readlink(/proc/self/exe)
989 includes a spurious NUL which will cause $^X to fail in system
990 or backticks (this will prevent extensions from being built and
991 many tests from working). readlink is not meant to add a NUL.
992 Normal readlink works fine.
993 */
994 if (len > 0 && buf[len-1] == '\0') {
995 len--;
996 }
997
998 /* FreeBSD's implementation is acknowledged to be imperfect, sometimes
999 returning the text "unknown" from the readlink rather than the path
1000 to the executable (or returning an error from the readlink). Any valid
1001 path has a '/' in it somewhere, so use that to validate the result.
1002 See http://www.freebsd.org/cgi/query-pr.cgi?pr=35703
1003 */
1004 if (len > 0 && memchr(buf, '/', len)) {
1005 sv_setpvn(sv,buf,len);
1006 }
1007 else {
1008 sv_setpv(sv,arg0);
1009 }
1010}
1011#endif /* HAS_PROCSELFEXE */
b7975bdd
NC		 1012
1013STATIC void
1014S_set_caret_X(pTHX) {
1015 GV* tmpgv = gv_fetchpv("\030",TRUE, SVt_PV); /* $^X */
1016 if (tmpgv) {
1017#ifdef HAS_PROCSELFEXE
1018 S_procself_val(aTHX_ GvSV(tmpgv), PL_origargv[0]);
1019#else
1020#ifdef OS2
1021 sv_setpv(GvSV(tmpgv), os2_execname(aTHX));
1022#else
1023 sv_setpv(GvSV(tmpgv),PL_origargv[0]);
1024#endif
1025#endif
1026 }
1027}
1028
954c1994
GS		 1029/*
1030=for apidoc perl_parse
1031
1032Tells a Perl interpreter to parse a Perl script. See L<perlembed>.
1033
1034=cut
1035*/
1036
79072805 1037int
0cb96387 1038perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env)
8d063cd8 1039{
6224f72b 1040 I32 oldscope;
6224f72b 1041 int ret;
db36c5a1 1042 dJMPENV;
8d063cd8 1043
a687059c
LW		 1044#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
1045#ifdef IAMSUID
1046#undef IAMSUID
cea2e8a9 1047 Perl_croak(aTHX_ "suidperl is no longer needed since the kernel can now execute\n\
a687059c 1048setuid perl scripts securely.\n");
ae3f3efd 1049#endif /* IAMSUID */
a687059c
LW		 1050#endif
1051
b0891165
JH		 1052#if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT)
1053 /* [perl #22371] Algorimic Complexity Attack on Perl 5.6.1, 5.8.0
103dd899 1054 * This MUST be done before any hash stores or fetches take place.
008fb0c0
NC		 1055 * If you set PL_rehash_seed (and assumedly also PL_rehash_seed_set)
1056 * yourself, it is your responsibility to provide a good random seed!
830b38bd 1057 * You can also define PERL_HASH_SEED in compile time, see hv.h. */
008fb0c0
NC		 1058 if (!PL_rehash_seed_set)
1059 PL_rehash_seed = get_hash_seed();
b0891165 1060 {
bed60192
JH		 1061 char *s = PerlEnv_getenv("PERL_HASH_SEED_DEBUG");
1062
1063 if (s) {
1064 int i = atoi(s);
1065
1066 if (i == 1)
1067 PerlIO_printf(Perl_debug_log, "HASH_SEED = %"UVuf"\n",
008fb0c0 1068 PL_rehash_seed);
bed60192 1069 }
b0891165
JH		 1070 }
1071#endif /* #if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT) */
1072
3280af22 1073 PL_origargc = argc;
e2975953 1074 PL_origargv = argv;
a0d0e21e 1075
54bfe034 1076 {
3cb9023d
JH		 1077 /* Set PL_origalen be the sum of the contiguous argv[]
1078 * elements plus the size of the env in case that it is
e9137a8e 1079 * contiguous with the argv[]. This is used in mg.c:Perl_magic_set()
3cb9023d
JH		 1080 * as the maximum modifiable length of $0. In the worst case
1081 * the area we are able to modify is limited to the size of
43c32782 1082 * the original argv[0]. (See below for 'contiguous', though.)
3cb9023d 1083 * --jhi */
84458fbf 1084 char *s = NULL;
54bfe034 1085 int i;
7d8e7db3
JH		 1086 UV mask =
1087 ~(UV)(PTRSIZE == 4 ? 3 : PTRSIZE == 8 ? 7 : PTRSIZE == 16 ? 15 : 0);
43c32782
JH		 1088 /* Do the mask check only if the args seem like aligned. */
1089 UV aligned =
1090 (mask < ~(UV)0) && ((PTR2UV(argv[0]) & mask) == PTR2UV(argv[0]));
1091
1092 /* See if all the arguments are contiguous in memory. Note
1093 * that 'contiguous' is a loose term because some platforms
1094 * align the argv[] and the envp[]. If the arguments look
1095 * like non-aligned, assume that they are 'strictly' or
1096 * 'traditionally' contiguous. If the arguments look like
1097 * aligned, we just check that they are within aligned
1098 * PTRSIZE bytes. As long as no system has something bizarre
1099 * like the argv[] interleaved with some other data, we are
1100 * fine. (Did I just evoke Murphy's Law?) --jhi */
c8941eeb
JH		 1101 if (PL_origargv && PL_origargc >= 1 && (s = PL_origargv[0])) {
1102 while (*s) s++;
1103 for (i = 1; i < PL_origargc; i++) {
1104 if ((PL_origargv[i] == s + 1
43c32782 1105#ifdef OS2
c8941eeb 1106 || PL_origargv[i] == s + 2
43c32782 1107#endif
c8941eeb
JH		 1108 )
1109 ||
1110 (aligned &&
1111 (PL_origargv[i] > s &&
1112 PL_origargv[i] <=
1113 INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)))
1114 )
1115 {
1116 s = PL_origargv[i];
1117 while (*s) s++;
1118 }
1119 else
1120 break;
54bfe034 1121 }
54bfe034 1122 }
3cb9023d 1123 /* Can we grab env area too to be used as the area for $0? */
43c32782
JH		 1124 if (PL_origenviron) {
1125 if ((PL_origenviron[0] == s + 1
1126#ifdef OS2
1127 || (PL_origenviron[0] == s + 9 && (s += 8))
1128#endif
1129 )
1130 ||
1131 (aligned &&
1132 (PL_origenviron[0] > s &&
1133 PL_origenviron[0] <=
1134 INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)))
1135 )
1136 {
1137#ifndef OS2
1138 s = PL_origenviron[0];
1139 while (*s) s++;
1140#endif
1141 my_setenv("NoNe SuCh", Nullch);
1142 /* Force copy of environment. */
1143 for (i = 1; PL_origenviron[i]; i++) {
1144 if (PL_origenviron[i] == s + 1
1145 ||
1146 (aligned &&
1147 (PL_origenviron[i] > s &&
1148 PL_origenviron[i] <=
1149 INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)))
1150 )
1151 {
1152 s = PL_origenviron[i];
1153 while (*s) s++;
1154 }
1155 else
1156 break;
54bfe034 1157 }
43c32782 1158 }
54bfe034 1159 }
284e1220 1160 PL_origalen = s - PL_origargv[0] + 1;
54bfe034
JH		 1161 }
1162
3280af22 1163 if (PL_do_undump) {
a0d0e21e
LW		 1164
1165 /* Come here if running an undumped a.out. */
1166
3280af22
NIS		 1167 PL_origfilename = savepv(argv[0]);
1168 PL_do_undump = FALSE;
a0d0e21e 1169 cxstack_ix = -1; /* start label stack again */
748a9306 1170 init_ids();
b7975bdd
NC		 1171 assert (!PL_tainted);
1172 TAINT;
1173 S_set_caret_X(aTHX);
1174 TAINT_NOT;
a0d0e21e
LW		 1175 init_postdump_symbols(argc,argv,env);
1176 return 0;
1177 }
1178
3280af22 1179 if (PL_main_root) {
3280af22
NIS		 1180 op_free(PL_main_root);
1181 PL_main_root = Nullop;
ff0cee69 1182 }
3280af22
NIS		 1183 PL_main_start = Nullop;
1184 SvREFCNT_dec(PL_main_cv);
1185 PL_main_cv = Nullcv;
79072805 1186
3280af22
NIS		 1187 time(&PL_basetime);
1188 oldscope = PL_scopestack_ix;
599cee73 1189 PL_dowarn = G_WARN_OFF;
f86702cc 1190
14dd3ad8 1191 JMPENV_PUSH(ret);
6224f72b 1192 switch (ret) {
312caa8e 1193 case 0:
14dd3ad8 1194 parse_body(env,xsinit);
7d30b5c4
GS		 1195 if (PL_checkav)
1196 call_list(oldscope, PL_checkav);
14dd3ad8
GS		 1197 ret = 0;
1198 break;
6224f72b
GS		 1199 case 1:
1200 STATUS_ALL_FAILURE;
1201 /* FALL THROUGH */
1202 case 2:
1203 /* my_exit() was called */
3280af22 1204 while (PL_scopestack_ix > oldscope)
6224f72b
GS		 1205 LEAVE;
1206 FREETMPS;
3280af22 1207 PL_curstash = PL_defstash;
7d30b5c4
GS		 1208 if (PL_checkav)
1209 call_list(oldscope, PL_checkav);
14dd3ad8
GS		 1210 ret = STATUS_NATIVE_EXPORT;
1211 break;
6224f72b 1212 case 3:
bf49b057 1213 PerlIO_printf(Perl_error_log, "panic: top_env\n");
14dd3ad8
GS		 1214 ret = 1;
1215 break;
6224f72b 1216 }
14dd3ad8
GS		 1217 JMPENV_POP;
1218 return ret;
1219}
1220
312caa8e 1221STATIC void *
14dd3ad8 1222S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
312caa8e 1223{
312caa8e
CS		 1224 int argc = PL_origargc;
1225 char **argv = PL_origargv;
312caa8e 1226 char *scriptname = NULL;
312caa8e
CS		 1227 VOL bool dosearch = FALSE;
1228 char *validarg = "";
312caa8e
CS		 1229 register SV *sv;
1230 register char *s;
cf756827 1231 char *cddir = Nullch;
312caa8e 1232
ae3f3efd
PS		 1233 PL_fdscript = -1;
1234 PL_suidscript = -1;
3280af22 1235 sv_setpvn(PL_linestr,"",0);
79cb57f6 1236 sv = newSVpvn("",0); /* first used for -I flags */
6224f72b
GS		 1237 SAVEFREESV(sv);
1238 init_main_stash();
54310121 1239
6224f72b
GS		 1240 for (argc--,argv++; argc > 0; argc--,argv++) {
1241 if (argv[0][0] != '-' || !argv[0][1])
1242 break;
1243#ifdef DOSUID
1244 if (*validarg)
1245 validarg = " PHOOEY ";
1246 else
1247 validarg = argv[0];
ae3f3efd
PS		 1248 /*
1249 * Can we rely on the kernel to start scripts with argv[1] set to
1250 * contain all #! line switches (the whole line)? (argv[0] is set to
1251 * the interpreter name, argv[2] to the script name; argv[3] and
1252 * above may contain other arguments.)
1253 */
13281fa4 1254#endif
6224f72b
GS		 1255 s = argv[0]+1;
1256 reswitch:
1257 switch (*s) {
729a02f2 1258 case 'C':
1d5472a9
GS		 1259#ifndef PERL_STRICT_CR
1260 case '\r':
1261#endif
6224f72b
GS		 1262 case ' ':
1263 case '0':
1264 case 'F':
1265 case 'a':
1266 case 'c':
1267 case 'd':
1268 case 'D':
1269 case 'h':
1270 case 'i':
1271 case 'l':
1272 case 'M':
1273 case 'm':
1274 case 'n':
1275 case 'p':
1276 case 's':
1277 case 'u':
1278 case 'U':
1279 case 'v':
599cee73
PM		 1280 case 'W':
1281 case 'X':
6224f72b 1282 case 'w':
06492da6 1283 case 'A':
155aba94 1284 if ((s = moreswitches(s)))
6224f72b
GS		 1285 goto reswitch;
1286 break;
33b78306 1287
1dbad523 1288 case 't':
22f7c9c9 1289 CHECK_MALLOC_TOO_LATE_FOR('t');
317ea90d
MS		 1290 if( !PL_tainting ) {
1291 PL_taint_warn = TRUE;
1292 PL_tainting = TRUE;
1293 }
1294 s++;
1295 goto reswitch;
6224f72b 1296 case 'T':
22f7c9c9 1297 CHECK_MALLOC_TOO_LATE_FOR('T');
3280af22 1298 PL_tainting = TRUE;
317ea90d 1299 PL_taint_warn = FALSE;
6224f72b
GS		 1300 s++;
1301 goto reswitch;
f86702cc 1302
6224f72b 1303 case 'e':
bf4acbe4
GS		 1304#ifdef MACOS_TRADITIONAL
1305 /* ignore -e for Dev:Pseudo argument */
1306 if (argv[1] && !strcmp(argv[1], "Dev:Pseudo"))
e55ac0fa 1307 break;
bf4acbe4 1308#endif
ae3f3efd 1309 forbid_setid("-e");
3280af22 1310 if (!PL_e_script) {
79cb57f6 1311 PL_e_script = newSVpvn("",0);
0cb96387 1312 filter_add(read_e_script, NULL);
6224f72b
GS		 1313 }
1314 if (*++s)
3280af22 1315 sv_catpv(PL_e_script, s);
6224f72b 1316 else if (argv[1]) {
3280af22 1317 sv_catpv(PL_e_script, argv[1]);
6224f72b
GS		 1318 argc--,argv++;
1319 }
1320 else
cea2e8a9 1321 Perl_croak(aTHX_ "No code specified for -e");
3280af22 1322 sv_catpv(PL_e_script, "\n");
6224f72b 1323 break;
afe37c7d 1324
6224f72b
GS		 1325 case 'I': /* -I handled both here and in moreswitches() */
1326 forbid_setid("-I");
1327 if (!*++s && (s=argv[1]) != Nullch) {
1328 argc--,argv++;
1329 }
6224f72b 1330 if (s && *s) {
0df16ed7
GS		 1331 char *p;
1332 STRLEN len = strlen(s);
1333 p = savepvn(s, len);
88fe16b2 1334 incpush(p, TRUE, TRUE, FALSE, FALSE);
0df16ed7
GS		 1335 sv_catpvn(sv, "-I", 2);
1336 sv_catpvn(sv, p, len);
1337 sv_catpvn(sv, " ", 1);
6224f72b 1338 Safefree(p);
0df16ed7
GS		 1339 }
1340 else
a67e862a 1341 Perl_croak(aTHX_ "No directory specified for -I");
6224f72b
GS		 1342 break;
1343 case 'P':
1344 forbid_setid("-P");
3280af22 1345 PL_preprocess = TRUE;
6224f72b
GS		 1346 s++;
1347 goto reswitch;
1348 case 'S':
1349 forbid_setid("-S");
1350 dosearch = TRUE;
1351 s++;
1352 goto reswitch;
1353 case 'V':
3280af22
NIS		 1354 if (!PL_preambleav)
1355 PL_preambleav = newAV();
1356 av_push(PL_preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
6224f72b 1357 if (*++s != ':') {
3280af22 1358 PL_Sv = newSVpv("print myconfig();",0);
6224f72b 1359#ifdef VMS
6b88bc9c 1360 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
6224f72b 1361#else
3280af22 1362 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
6224f72b 1363#endif
3280af22 1364 sv_catpv(PL_Sv,"\" Compile-time options:");
6224f72b 1365# ifdef DEBUGGING
3280af22 1366 sv_catpv(PL_Sv," DEBUGGING");
6224f72b 1367# endif
6224f72b 1368# ifdef MULTIPLICITY
8f872242 1369 sv_catpv(PL_Sv," MULTIPLICITY");
6224f72b 1370# endif
4d1ff10f
AB		 1371# ifdef USE_5005THREADS
1372 sv_catpv(PL_Sv," USE_5005THREADS");
b363f7ed 1373# endif
ac5e8965
JH		 1374# ifdef USE_ITHREADS
1375 sv_catpv(PL_Sv," USE_ITHREADS");
1376# endif
10cc9d2a
JH		 1377# ifdef USE_64_BIT_INT
1378 sv_catpv(PL_Sv," USE_64_BIT_INT");
1379# endif
1380# ifdef USE_64_BIT_ALL
1381 sv_catpv(PL_Sv," USE_64_BIT_ALL");
ac5e8965
JH		 1382# endif
1383# ifdef USE_LONG_DOUBLE
1384 sv_catpv(PL_Sv," USE_LONG_DOUBLE");
1385# endif
53430762
JH		 1386# ifdef USE_LARGE_FILES
1387 sv_catpv(PL_Sv," USE_LARGE_FILES");
1388# endif
ac5e8965
JH		 1389# ifdef USE_SOCKS
1390 sv_catpv(PL_Sv," USE_SOCKS");
1391# endif
b363f7ed
GS		 1392# ifdef PERL_IMPLICIT_CONTEXT
1393 sv_catpv(PL_Sv," PERL_IMPLICIT_CONTEXT");
1394# endif
1395# ifdef PERL_IMPLICIT_SYS
1396 sv_catpv(PL_Sv," PERL_IMPLICIT_SYS");
1397# endif
3280af22 1398 sv_catpv(PL_Sv,"\\n\",");
b363f7ed 1399
6224f72b
GS		 1400#if defined(LOCAL_PATCH_COUNT)
1401 if (LOCAL_PATCH_COUNT > 0) {
1402 int i;
3280af22 1403 sv_catpv(PL_Sv,"\" Locally applied patches:\\n\",");
6224f72b 1404 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
3280af22 1405 if (PL_localpatches[i])
acb03d05
AB		 1406 Perl_sv_catpvf(aTHX_ PL_Sv,"q%c\t%s\n%c,",
1407 0, PL_localpatches[i], 0);
6224f72b
GS		 1408 }
1409 }
1410#endif
cea2e8a9 1411 Perl_sv_catpvf(aTHX_ PL_Sv,"\" Built under %s\\n\"",OSNAME);
6224f72b
GS		 1412#ifdef __DATE__
1413# ifdef __TIME__
cea2e8a9 1414 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
6224f72b 1415# else
cea2e8a9 1416 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled on %s\\n\"",__DATE__);
6224f72b
GS		 1417# endif
1418#endif
3280af22 1419 sv_catpv(PL_Sv, "; \
6224f72b 1420$\"=\"\\n \"; \
69fcd688
JH		 1421@env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; ");
1422#ifdef __CYGWIN__
1423 sv_catpv(PL_Sv,"\
1424push @env, \"CYGWIN=\\\"$ENV{CYGWIN}\\\"\";");
1425#endif
1426 sv_catpv(PL_Sv, "\
6224f72b
GS		 1427print \" \\%ENV:\\n @env\\n\" if @env; \
1428print \" \\@INC:\\n @INC\\n\";");
1429 }
1430 else {
3280af22
NIS		 1431 PL_Sv = newSVpv("config_vars(qw(",0);
1432 sv_catpv(PL_Sv, ++s);
1433 sv_catpv(PL_Sv, "))");
6224f72b
GS		 1434 s += strlen(s);
1435 }
3280af22 1436 av_push(PL_preambleav, PL_Sv);
6224f72b
GS		 1437 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
1438 goto reswitch;
1439 case 'x':
3280af22 1440 PL_doextract = TRUE;
6224f72b
GS		 1441 s++;
1442 if (*s)
f4c556ac 1443 cddir = s;
6224f72b
GS		 1444 break;
1445 case 0:
1446 break;
1447 case '-':
1448 if (!*++s || isSPACE(*s)) {
1449 argc--,argv++;
1450 goto switch_end;
1451 }
1452 /* catch use of gnu style long options */
1453 if (strEQ(s, "version")) {
1454 s = "v";
1455 goto reswitch;
1456 }
1457 if (strEQ(s, "help")) {
1458 s = "h";
1459 goto reswitch;
1460 }
1461 s--;
1462 /* FALL THROUGH */
1463 default:
cea2e8a9 1464 Perl_croak(aTHX_ "Unrecognized switch: -%s (-h will show valid options)",s);
8d063cd8
LW		 1465 }
1466 }
6224f72b 1467 switch_end:
54310121 1468
f675dbe5
CB		 1469 if (
1470#ifndef SECURE_INTERNAL_GETENV
1471 !PL_tainting &&
1472#endif
cf756827 1473 (s = PerlEnv_getenv("PERL5OPT")))
0df16ed7 1474 {
cf756827 1475 char *popt = s;
74288ac8
GS		 1476 while (isSPACE(*s))
1477 s++;
317ea90d 1478 if (*s == '-' && *(s+1) == 'T') {
22f7c9c9 1479 CHECK_MALLOC_TOO_LATE_FOR('T');
74288ac8 1480 PL_tainting = TRUE;
317ea90d
MS		 1481 PL_taint_warn = FALSE;
1482 }
74288ac8 1483 else {
cf756827 1484 char *popt_copy = Nullch;
74288ac8 1485 while (s && *s) {
4ea8f8fb 1486 char *d;
74288ac8
GS		 1487 while (isSPACE(*s))
1488 s++;
1489 if (*s == '-') {
1490 s++;
1491 if (isSPACE(*s))
1492 continue;
1493 }
4ea8f8fb 1494 d = s;
74288ac8
GS		 1495 if (!*s)
1496 break;
06492da6 1497 if (!strchr("DIMUdmtwA", *s))
cea2e8a9 1498 Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s);
4ea8f8fb
MS		 1499 while (++s && *s) {
1500 if (isSPACE(*s)) {
cf756827
GS		 1501 if (!popt_copy) {
1502 popt_copy = SvPVX(sv_2mortal(newSVpv(popt,0)));
1503 s = popt_copy + (s - popt);
1504 d = popt_copy + (d - popt);
1505 }
4ea8f8fb
MS		 1506 *s++ = '\0';
1507 break;
1508 }
1509 }
1c4db469 1510 if (*d == 't') {
317ea90d
MS		 1511 if( !PL_tainting ) {
1512 PL_taint_warn = TRUE;
1513 PL_tainting = TRUE;
1514 }
1c4db469
RGS		 1515 } else {
1516 moreswitches(d);
1517 }
6224f72b 1518 }
6224f72b
GS		 1519 }
1520 }
a0d0e21e 1521
317ea90d
MS		 1522 if (PL_taint_warn && PL_dowarn != G_WARN_ALL_OFF) {
1523 PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
1524 }
1525
6224f72b
GS		 1526 if (!scriptname)
1527 scriptname = argv[0];
3280af22 1528 if (PL_e_script) {
6224f72b
GS		 1529 argc++,argv--;
1530 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
1531 }
1532 else if (scriptname == Nullch) {
1533#ifdef MSDOS
1534 if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
1535 moreswitches("h");
1536#endif
1537 scriptname = "-";
1538 }
1539
b7975bdd
NC		 1540 /* Set $^X early so that it can be used for relocatable paths in @INC */
1541 assert (!PL_tainted);
1542 TAINT;
1543 S_set_caret_X(aTHX);
1544 TAINT_NOT;
6224f72b
GS		 1545 init_perllib();
1546
c5cccb17 1547 open_script(scriptname,dosearch,sv);
6224f72b 1548
c5cccb17 1549 validate_suid(validarg, scriptname);
6224f72b 1550
64ca3a65 1551#ifndef PERL_MICRO
0b5b802d
GS		 1552#if defined(SIGCHLD) || defined(SIGCLD)
1553 {
1554#ifndef SIGCHLD
1555# define SIGCHLD SIGCLD
1556#endif
1557 Sighandler_t sigstate = rsignal_state(SIGCHLD);
1558 if (sigstate == SIG_IGN) {
1559 if (ckWARN(WARN_SIGNAL))
9014280d 1560 Perl_warner(aTHX_ packWARN(WARN_SIGNAL),
0b5b802d
GS		 1561 "Can't ignore signal CHLD, forcing to default");
1562 (void)rsignal(SIGCHLD, (Sighandler_t)SIG_DFL);
1563 }
1564 }
1565#endif
64ca3a65 1566#endif
0b5b802d 1567
bf4acbe4
GS		 1568#ifdef MACOS_TRADITIONAL
1569 if (PL_doextract || gMacPerl_AlwaysExtract) {
1570#else
f4c556ac 1571 if (PL_doextract) {
bf4acbe4 1572#endif
6224f72b 1573 find_beginning();
f4c556ac
GS		 1574 if (cddir && PerlDir_chdir(cddir) < 0)
1575 Perl_croak(aTHX_ "Can't chdir to %s",cddir);
1576
1577 }
6224f72b 1578
3280af22
NIS		 1579 PL_main_cv = PL_compcv = (CV*)NEWSV(1104,0);
1580 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
1581 CvUNIQUE_on(PL_compcv);
1582
dd2155a4 1583 CvPADLIST(PL_compcv) = pad_new(0);
4d1ff10f 1584#ifdef USE_5005THREADS
533c011a
NIS		 1585 CvOWNER(PL_compcv) = 0;
1586 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
1587 MUTEX_INIT(CvMUTEXP(PL_compcv));
4d1ff10f 1588#endif /* USE_5005THREADS */
6224f72b 1589
0c4f7ff0 1590 boot_core_PerlIO();
6224f72b 1591 boot_core_UNIVERSAL();
09bef843 1592 boot_core_xsutils();
6224f72b
GS		 1593
1594 if (xsinit)
acfe0abc 1595 (*xsinit)(aTHX); /* in case linked C routines want magical variables */
64ca3a65 1596#ifndef PERL_MICRO
ed79a026 1597#if defined(VMS) || defined(WIN32) || defined(DJGPP) || defined(__CYGWIN__) || defined(EPOC)
c5be433b 1598 init_os_extras();
6224f72b 1599#endif
64ca3a65 1600#endif
6224f72b 1601
29209bc5 1602#ifdef USE_SOCKS
1b9c9cf5
DH		 1603# ifdef HAS_SOCKS5_INIT
1604 socks5_init(argv[0]);
1605# else
29209bc5 1606 SOCKSinit(argv[0]);
1b9c9cf5 1607# endif
ac27b0f5 1608#endif
29209bc5 1609
6224f72b
GS		 1610 init_predump_symbols();
1611 /* init_postdump_symbols not currently designed to be called */
1612 /* more than once (ENV isn't cleared first, for example) */
1613 /* But running with -u leaves %ENV & @ARGV undefined! XXX */
3280af22 1614 if (!PL_do_undump)
6224f72b
GS		 1615 init_postdump_symbols(argc,argv,env);
1616
a05d7ebb
JH		 1617 /* PL_unicode is turned on by -C or by $ENV{PERL_UNICODE}.
1618 * PL_utf8locale is conditionally turned on by
085a54d9 1619 * locale.c:Perl_init_i18nl10n() if the environment
a05d7ebb 1620 * look like the user wants to use UTF-8. */
06e66572
JH		 1621 if (PL_unicode) {
1622 /* Requires init_predump_symbols(). */
a05d7ebb 1623 if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) {
06e66572
JH		 1624 IO* io;
1625 PerlIO* fp;
1626 SV* sv;
1627
a05d7ebb 1628 /* Turn on UTF-8-ness on STDIN, STDOUT, STDERR
06e66572 1629 * and the default open disciplines. */
a05d7ebb
JH		 1630 if ((PL_unicode & PERL_UNICODE_STDIN_FLAG) &&
1631 PL_stdingv && (io = GvIO(PL_stdingv)) &&
1632 (fp = IoIFP(io)))
1633 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
1634 if ((PL_unicode & PERL_UNICODE_STDOUT_FLAG) &&
1635 PL_defoutgv && (io = GvIO(PL_defoutgv)) &&
1636 (fp = IoOFP(io)))
1637 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
1638 if ((PL_unicode & PERL_UNICODE_STDERR_FLAG) &&
1639 PL_stderrgv && (io = GvIO(PL_stderrgv)) &&
1640 (fp = IoOFP(io)))
1641 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
1642 if ((PL_unicode & PERL_UNICODE_INOUT_FLAG) &&
1643 (sv = GvSV(gv_fetchpv("\017PEN", TRUE, SVt_PV)))) {
1644 U32 in = PL_unicode & PERL_UNICODE_IN_FLAG;
1645 U32 out = PL_unicode & PERL_UNICODE_OUT_FLAG;
1646 if (in) {
1647 if (out)
1648 sv_setpvn(sv, ":utf8\0:utf8", 11);
1649 else
1650 sv_setpvn(sv, ":utf8\0", 6);
1651 }
1652 else if (out)
1653 sv_setpvn(sv, "\0:utf8", 6);
1654 SvSETMAGIC(sv);
1655 }
b310b053
JH		 1656 }
1657 }
1658
4ffa73a3
JH		 1659 if ((s = PerlEnv_getenv("PERL_SIGNALS"))) {
1660 if (strEQ(s, "unsafe"))
1661 PL_signals |= PERL_SIGNALS_UNSAFE_FLAG;
1662 else if (strEQ(s, "safe"))
1663 PL_signals &= ~PERL_SIGNALS_UNSAFE_FLAG;
1664 else
1665 Perl_croak(aTHX_ "PERL_SIGNALS illegal: \"%s\"", s);
1666 }
1667
6224f72b
GS		 1668 init_lexer();
1669
1670 /* now parse the script */
1671
93189314 1672 SETERRNO(0,SS_NORMAL);
3280af22 1673 PL_error_count = 0;
bf4acbe4
GS		 1674#ifdef MACOS_TRADITIONAL
1675 if (gMacPerl_SyntaxError = (yyparse() || PL_error_count)) {
1676 if (PL_minus_c)
1677 Perl_croak(aTHX_ "%s had compilation errors.\n", MacPerl_MPWFileName(PL_origfilename));
1678 else {
1679 Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
1680 MacPerl_MPWFileName(PL_origfilename));
1681 }
1682 }
1683#else
3280af22
NIS		 1684 if (yyparse() || PL_error_count) {
1685 if (PL_minus_c)
cea2e8a9 1686 Perl_croak(aTHX_ "%s had compilation errors.\n", PL_origfilename);
6224f72b 1687 else {
cea2e8a9 1688 Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
097ee67d 1689 PL_origfilename);
6224f72b
GS		 1690 }
1691 }
bf4acbe4 1692#endif
57843af0 1693 CopLINE_set(PL_curcop, 0);
3280af22
NIS		 1694 PL_curstash = PL_defstash;
1695 PL_preprocess = FALSE;
1696 if (PL_e_script) {
1697 SvREFCNT_dec(PL_e_script);
1698 PL_e_script = Nullsv;
6224f72b
GS		 1699 }
1700
3280af22 1701 if (PL_do_undump)
6224f72b
GS		 1702 my_unexec();
1703
57843af0
GS		 1704 if (isWARN_ONCE) {
1705 SAVECOPFILE(PL_curcop);
1706 SAVECOPLINE(PL_curcop);
3280af22 1707 gv_check(PL_defstash);
57843af0 1708 }
6224f72b
GS		 1709
1710 LEAVE;
1711 FREETMPS;
1712
1713#ifdef MYMALLOC
1714 if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
1715 dump_mstats("after compilation:");
1716#endif
1717
1718 ENTER;
3280af22 1719 PL_restartop = 0;
312caa8e 1720 return NULL;
6224f72b
GS		 1721}
1722
954c1994
GS		 1723/*
1724=for apidoc perl_run
1725
1726Tells a Perl interpreter to run. See L<perlembed>.
1727
1728=cut
1729*/
1730
6224f72b 1731int
0cb96387 1732perl_run(pTHXx)
6224f72b 1733{
6224f72b 1734 I32 oldscope;
14dd3ad8 1735 int ret = 0;
db36c5a1 1736 dJMPENV;
6224f72b 1737
3280af22 1738 oldscope = PL_scopestack_ix;
96e176bf
CL		 1739#ifdef VMS
1740 VMSISH_HUSHED = 0;
1741#endif
6224f72b 1742
14dd3ad8 1743 JMPENV_PUSH(ret);
6224f72b
GS		 1744 switch (ret) {
1745 case 1:
1746 cxstack_ix = -1; /* start context stack again */
312caa8e 1747 goto redo_body;
14dd3ad8 1748 case 0: /* normal completion */
14dd3ad8
GS		 1749 redo_body:
1750 run_body(oldscope);
14dd3ad8
GS		 1751 /* FALL THROUGH */
1752 case 2: /* my_exit() */
3280af22 1753 while (PL_scopestack_ix > oldscope)
6224f72b
GS		 1754 LEAVE;
1755 FREETMPS;
3280af22 1756 PL_curstash = PL_defstash;
3a1ee7e8 1757 if (!(PL_exit_flags & PERL_EXIT_DESTRUCT_END) &&
31d77e54
AB		 1758 PL_endav && !PL_minus_c)
1759 call_list(oldscope, PL_endav);
6224f72b
GS		 1760#ifdef MYMALLOC
1761 if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
1762 dump_mstats("after execution: ");
1763#endif
14dd3ad8
GS		 1764 ret = STATUS_NATIVE_EXPORT;
1765 break;
6224f72b 1766 case 3:
312caa8e
CS		 1767 if (PL_restartop) {
1768 POPSTACK_TO(PL_mainstack);
1769 goto redo_body;
6224f72b 1770 }
bf49b057 1771 PerlIO_printf(Perl_error_log, "panic: restartop\n");
312caa8e 1772 FREETMPS;
14dd3ad8
GS		 1773 ret = 1;
1774 break;
6224f72b
GS		 1775 }
1776
14dd3ad8
GS		 1777 JMPENV_POP;
1778 return ret;
312caa8e
CS		 1779}
1780
14dd3ad8
GS		 1781
1782STATIC void *
1783S_run_body(pTHX_ I32 oldscope)
1784{
6224f72b 1785 DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
3280af22 1786 PL_sawampersand ? "Enabling" : "Omitting"));
6224f72b 1787
3280af22 1788 if (!PL_restartop) {
6224f72b 1789 DEBUG_x(dump_all());
ecae49c0
NC		 1790 if (!DEBUG_q_TEST)
1791 PERL_DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
b900a521
JH		 1792 DEBUG_S(PerlIO_printf(Perl_debug_log, "main thread is 0x%"UVxf"\n",
1793 PTR2UV(thr)));
6224f72b 1794
3280af22 1795 if (PL_minus_c) {
bf4acbe4 1796#ifdef MACOS_TRADITIONAL
e69a2255
JH		 1797 PerlIO_printf(Perl_error_log, "%s%s syntax OK\n",
1798 (gMacPerl_ErrorFormat ? "# " : ""),
1799 MacPerl_MPWFileName(PL_origfilename));
bf4acbe4 1800#else
bf49b057 1801 PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename);
bf4acbe4 1802#endif
6224f72b
GS		 1803 my_exit(0);
1804 }
3280af22 1805 if (PERLDB_SINGLE && PL_DBsingle)
ac27b0f5 1806 sv_setiv(PL_DBsingle, 1);
3280af22
NIS		 1807 if (PL_initav)
1808 call_list(oldscope, PL_initav);
6224f72b
GS		 1809 }
1810
1811 /* do it */
1812
3280af22 1813 if (PL_restartop) {
533c011a 1814 PL_op = PL_restartop;
3280af22 1815 PL_restartop = 0;
cea2e8a9 1816 CALLRUNOPS(aTHX);
6224f72b 1817 }
3280af22
NIS		 1818 else if (PL_main_start) {
1819 CvDEPTH(PL_main_cv) = 1;
533c011a 1820 PL_op = PL_main_start;
cea2e8a9 1821 CALLRUNOPS(aTHX);
6224f72b
GS		 1822 }
1823
f6b3007c
JH		 1824 my_exit(0);
1825 /* NOTREACHED */
312caa8e 1826 return NULL;
6224f72b
GS		 1827}
1828
954c1994 1829/*
ccfc67b7
JH		 1830=head1 SV Manipulation Functions
1831
954c1994
GS		 1832=for apidoc p||get_sv
1833
1834Returns the SV of the specified Perl scalar. If C<create> is set and the
1835Perl variable does not exist then it will be created. If C<create> is not
1836set and the variable does not exist then NULL is returned.
1837
1838=cut
1839*/
1840
6224f72b 1841SV*
864dbfa3 1842Perl_get_sv(pTHX_ const char *name, I32 create)
6224f72b
GS		 1843{
1844 GV *gv;
4d1ff10f 1845#ifdef USE_5005THREADS
6224f72b
GS		 1846 if (name[1] == '\0' && !isALPHA(name[0])) {
1847 PADOFFSET tmp = find_threadsv(name);
411caa50 1848 if (tmp != NOT_IN_PAD)
6224f72b 1849 return THREADSV(tmp);
6224f72b 1850 }
4d1ff10f 1851#endif /* USE_5005THREADS */
6224f72b
GS		 1852 gv = gv_fetchpv(name, create, SVt_PV);
1853 if (gv)
1854 return GvSV(gv);
1855 return Nullsv;
1856}
1857
954c1994 1858/*
ccfc67b7
JH		 1859=head1 Array Manipulation Functions
1860
954c1994
GS		 1861=for apidoc p||get_av
1862
1863Returns the AV of the specified Perl array. If C<create> is set and the
1864Perl variable does not exist then it will be created. If C<create> is not
1865set and the variable does not exist then NULL is returned.
1866
1867=cut
1868*/
1869
6224f72b 1870AV*
864dbfa3 1871Perl_get_av(pTHX_ const char *name, I32 create)
6224f72b
GS		 1872{
1873 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
1874 if (create)
1875 return GvAVn(gv);
1876 if (gv)
1877 return GvAV(gv);
1878 return Nullav;
1879}
1880
954c1994 1881/*
ccfc67b7
JH		 1882=head1 Hash Manipulation Functions
1883
954c1994
GS		 1884=for apidoc p||get_hv
1885
1886Returns the HV of the specified Perl hash. If C<create> is set and the
1887Perl variable does not exist then it will be created. If C<create> is not
1888set and the variable does not exist then NULL is returned.
1889
1890=cut
1891*/
1892
6224f72b 1893HV*
864dbfa3 1894Perl_get_hv(pTHX_ const char *name, I32 create)
6224f72b 1895{
a0d0e21e
LW		 1896 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
1897 if (create)
1898 return GvHVn(gv);
1899 if (gv)
1900 return GvHV(gv);
1901 return Nullhv;
1902}
1903
954c1994 1904/*
ccfc67b7
JH		 1905=head1 CV Manipulation Functions
1906
954c1994
GS		 1907=for apidoc p||get_cv
1908
1909Returns the CV of the specified Perl subroutine. If C<create> is set and
1910the Perl subroutine does not exist then it will be declared (which has the
1911same effect as saying C<sub name;>). If C<create> is not set and the
1912subroutine does not exist then NULL is returned.
1913
1914=cut
1915*/
1916
a0d0e21e 1917CV*
864dbfa3 1918Perl_get_cv(pTHX_ const char *name, I32 create)
a0d0e21e
LW		 1919{
1920 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
b099ddc0 1921 /* XXX unsafe for threads if eval_owner isn't held */
f6ec51f7
GS		 1922 /* XXX this is probably not what they think they're getting.
1923 * It has the same effect as "sub name;", i.e. just a forward
1924 * declaration! */
8ebc5c01 1925 if (create && !GvCVu(gv))
774d564b 1926 return newSUB(start_subparse(FALSE, 0),
a0d0e21e 1927 newSVOP(OP_CONST, 0, newSVpv(name,0)),
4633a7c4 1928 Nullop,
a0d0e21e
LW		 1929 Nullop);
1930 if (gv)
8ebc5c01 1931 return GvCVu(gv);
a0d0e21e
LW		 1932 return Nullcv;
1933}
1934
79072805
LW		 1935/* Be sure to refetch the stack pointer after calling these routines. */
1936
954c1994 1937/*
ccfc67b7
JH		 1938
1939=head1 Callback Functions
1940
954c1994
GS		 1941=for apidoc p||call_argv
1942
1943Performs a callback to the specified Perl sub. See L<perlcall>.
1944
1945=cut
1946*/
1947
a0d0e21e 1948I32
864dbfa3 1949Perl_call_argv(pTHX_ const char *sub_name, I32 flags, register char **argv)
ac27b0f5 1950
8ac85365
NIS		 1951 /* See G_* flags in cop.h */
1952 /* null terminated arg list */
8990e307 1953{
a0d0e21e 1954 dSP;
8990e307 1955
924508f0 1956 PUSHMARK(SP);
a0d0e21e 1957 if (argv) {
8990e307 1958 while (*argv) {
a0d0e21e 1959 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
8990e307
LW		 1960 argv++;
1961 }
a0d0e21e 1962 PUTBACK;
8990e307 1963 }
864dbfa3 1964 return call_pv(sub_name, flags);
8990e307
LW		 1965}
1966
954c1994
GS		 1967/*
1968=for apidoc p||call_pv
1969
1970Performs a callback to the specified Perl sub. See L<perlcall>.
1971
1972=cut
1973*/
1974
a0d0e21e 1975I32
864dbfa3 1976Perl_call_pv(pTHX_ const char *sub_name, I32 flags)
8ac85365
NIS		 1977 /* name of the subroutine */
1978 /* See G_* flags in cop.h */
a0d0e21e 1979{
864dbfa3 1980 return call_sv((SV*)get_cv(sub_name, TRUE), flags);
a0d0e21e
LW		 1981}
1982
954c1994
GS		 1983/*
1984=for apidoc p||call_method
1985
1986Performs a callback to the specified Perl method. The blessed object must
1987be on the stack. See L<perlcall>.
1988
1989=cut
1990*/
1991
a0d0e21e 1992I32
864dbfa3 1993Perl_call_method(pTHX_ const char *methname, I32 flags)
8ac85365
NIS		 1994 /* name of the subroutine */
1995 /* See G_* flags in cop.h */
a0d0e21e 1996{
968b3946 1997 return call_sv(sv_2mortal(newSVpv(methname,0)), flags | G_METHOD);
a0d0e21e
LW		 1998}
1999
2000/* May be called with any of a CV, a GV, or an SV containing the name. */
954c1994
GS		 2001/*
2002=for apidoc p||call_sv
2003
2004Performs a callback to the Perl sub whose name is in the SV. See
2005L<perlcall>.
2006
2007=cut
2008*/
2009
a0d0e21e 2010I32
864dbfa3 2011Perl_call_sv(pTHX_ SV *sv, I32 flags)
8ac85365 2012 /* See G_* flags in cop.h */
a0d0e21e 2013{
924508f0 2014 dSP;
a0d0e21e 2015 LOGOP myop; /* fake syntax tree node */
968b3946 2016 UNOP method_op;
aa689395 2017 I32 oldmark;
13689cfe 2018 volatile I32 retval = 0;
a0d0e21e 2019 I32 oldscope;
54310121 2020 bool oldcatch = CATCH_GET;
6224f72b 2021 int ret;
533c011a 2022 OP* oldop = PL_op;
db36c5a1 2023 dJMPENV;
1e422769 2024
a0d0e21e
LW		 2025 if (flags & G_DISCARD) {
2026 ENTER;
2027 SAVETMPS;
2028 }
2029
aa689395 2030 Zero(&myop, 1, LOGOP);
54310121 2031 myop.op_next = Nullop;
f51d4af5 2032 if (!(flags & G_NOARGS))
aa689395 2033 myop.op_flags |= OPf_STACKED;
54310121 2034 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
2035 (flags & G_ARRAY) ? OPf_WANT_LIST :
2036 OPf_WANT_SCALAR);
462e5cf6 2037 SAVEOP();
533c011a 2038 PL_op = (OP*)&myop;
aa689395 2039
3280af22
NIS		 2040 EXTEND(PL_stack_sp, 1);
2041 *++PL_stack_sp = sv;
aa689395 2042 oldmark = TOPMARK;
3280af22 2043 oldscope = PL_scopestack_ix;
a0d0e21e 2044
3280af22 2045 if (PERLDB_SUB && PL_curstash != PL_debstash
36477c24 2046 /* Handle first BEGIN of -d. */
3280af22 2047 && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub)))
36477c24 2048 /* Try harder, since this may have been a sighandler, thus
2049 * curstash may be meaningless. */
3280af22 2050 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != PL_debstash)
491527d0 2051 && !(flags & G_NODEBUG))
533c011a 2052 PL_op->op_private |= OPpENTERSUB_DB;
a0d0e21e 2053
968b3946
GS		 2054 if (flags & G_METHOD) {
2055 Zero(&method_op, 1, UNOP);
2056 method_op.op_next = PL_op;
2057 method_op.op_ppaddr = PL_ppaddr[OP_METHOD];
2058 myop.op_ppaddr = PL_ppaddr[OP_ENTERSUB];
f39d0b86 2059 PL_op = (OP*)&method_op;
968b3946
GS		 2060 }
2061
312caa8e 2062 if (!(flags & G_EVAL)) {
0cdb2077 2063 CATCH_SET(TRUE);
14dd3ad8 2064 call_body((OP*)&myop, FALSE);
312caa8e 2065 retval = PL_stack_sp - (PL_stack_base + oldmark);
0253cb41 2066 CATCH_SET(oldcatch);
312caa8e
CS		 2067 }
2068 else {
d78bda3d 2069 myop.op_other = (OP*)&myop;
3280af22 2070 PL_markstack_ptr--;
4633a7c4
LW		 2071 /* we're trying to emulate pp_entertry() here */
2072 {
c09156bb 2073 register PERL_CONTEXT *cx;
54310121 2074 I32 gimme = GIMME_V;
ac27b0f5 2075
4633a7c4
LW		 2076 ENTER;
2077 SAVETMPS;
ac27b0f5 2078
1d76a5c3 2079 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
4633a7c4 2080 PUSHEVAL(cx, 0, 0);
533c011a 2081 PL_eval_root = PL_op; /* Only needed so that goto works right. */
ac27b0f5 2082
faef0170 2083 PL_in_eval = EVAL_INEVAL;
4633a7c4 2084 if (flags & G_KEEPERR)
faef0170 2085 PL_in_eval |= EVAL_KEEPERR;
4633a7c4 2086 else
38a03e6e 2087 sv_setpv(ERRSV,"");
4633a7c4 2088 }
3280af22 2089 PL_markstack_ptr++;
a0d0e21e 2090
14dd3ad8 2091 JMPENV_PUSH(ret);
6224f72b
GS		 2092 switch (ret) {
2093 case 0:
14dd3ad8
GS		 2094 redo_body:
2095 call_body((OP*)&myop, FALSE);
312caa8e
CS		 2096 retval = PL_stack_sp - (PL_stack_base + oldmark);
2097 if (!(flags & G_KEEPERR))
2098 sv_setpv(ERRSV,"");
a0d0e21e 2099 break;
6224f72b 2100 case 1:
f86702cc 2101 STATUS_ALL_FAILURE;
a0d0e21e 2102 /* FALL THROUGH */
6224f72b 2103 case 2:
a0d0e21e 2104 /* my_exit() was called */
3280af22 2105 PL_curstash = PL_defstash;
a0d0e21e 2106 FREETMPS;
14dd3ad8 2107 JMPENV_POP;
cc3604b1 2108 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
cea2e8a9 2109 Perl_croak(aTHX_ "Callback called exit");
f86702cc 2110 my_exit_jump();
a0d0e21e 2111 /* NOTREACHED */
6224f72b 2112 case 3:
3280af22 2113 if (PL_restartop) {
533c011a 2114 PL_op = PL_restartop;
3280af22 2115 PL_restartop = 0;
312caa8e 2116 goto redo_body;
a0d0e21e 2117 }
3280af22 2118 PL_stack_sp = PL_stack_base + oldmark;
a0d0e21e
LW		 2119 if (flags & G_ARRAY)
2120 retval = 0;
2121 else {
2122 retval = 1;
3280af22 2123 *++PL_stack_sp = &PL_sv_undef;
a0d0e21e 2124 }
312caa8e 2125 break;
a0d0e21e 2126 }
a0d0e21e 2127
3280af22 2128 if (PL_scopestack_ix > oldscope) {
a0a2876f
LW		 2129 SV **newsp;
2130 PMOP *newpm;
2131 I32 gimme;
c09156bb 2132 register PERL_CONTEXT *cx;
a0a2876f
LW		 2133 I32 optype;
2134
2135 POPBLOCK(cx,newpm);
2136 POPEVAL(cx);
3280af22 2137 PL_curpm = newpm;
a0a2876f 2138 LEAVE;
a0d0e21e 2139 }
14dd3ad8 2140 JMPENV_POP;
a0d0e21e 2141 }
1e422769 2142
a0d0e21e 2143 if (flags & G_DISCARD) {
3280af22 2144 PL_stack_sp = PL_stack_base + oldmark;
a0d0e21e
LW		 2145 retval = 0;
2146 FREETMPS;
2147 LEAVE;
2148 }
533c011a 2149 PL_op = oldop;
a0d0e21e
LW		 2150 return retval;
2151}
2152
312caa8e 2153STATIC void
14dd3ad8 2154S_call_body(pTHX_ OP *myop, int is_eval)
312caa8e 2155{
312caa8e
CS		 2156 if (PL_op == myop) {
2157 if (is_eval)
f807eda9 2158 PL_op = Perl_pp_entereval(aTHX); /* this doesn't do a POPMARK */
312caa8e 2159 else
f807eda9 2160 PL_op = Perl_pp_entersub(aTHX); /* this does */
312caa8e
CS		 2161 }
2162 if (PL_op)
cea2e8a9 2163 CALLRUNOPS(aTHX);
312caa8e
CS		 2164}
2165
6e72f9df 2166/* Eval a string. The G_EVAL flag is always assumed. */
8990e307 2167
954c1994
GS		 2168/*
2169=for apidoc p||eval_sv
2170
2171Tells Perl to C<eval> the string in the SV.
2172
2173=cut
2174*/
2175
a0d0e21e 2176I32
864dbfa3 2177Perl_eval_sv(pTHX_ SV *sv, I32 flags)
ac27b0f5 2178
8ac85365 2179 /* See G_* flags in cop.h */
a0d0e21e 2180{
924508f0 2181 dSP;
a0d0e21e 2182 UNOP myop; /* fake syntax tree node */
8fa7f367 2183 volatile I32 oldmark = SP - PL_stack_base;
13689cfe 2184 volatile I32 retval = 0;
4633a7c4 2185 I32 oldscope;
6224f72b 2186 int ret;
533c011a 2187 OP* oldop = PL_op;
db36c5a1 2188 dJMPENV;
84902520 2189
4633a7c4
LW		 2190 if (flags & G_DISCARD) {
2191 ENTER;
2192 SAVETMPS;
2193 }
2194
462e5cf6 2195 SAVEOP();
533c011a
NIS		 2196 PL_op = (OP*)&myop;
2197 Zero(PL_op, 1, UNOP);
3280af22
NIS		 2198 EXTEND(PL_stack_sp, 1);
2199 *++PL_stack_sp = sv;
2200 oldscope = PL_scopestack_ix;
79072805 2201
4633a7c4
LW		 2202 if (!(flags & G_NOARGS))
2203 myop.op_flags = OPf_STACKED;
79072805 2204 myop.op_next = Nullop;
6e72f9df 2205 myop.op_type = OP_ENTEREVAL;
54310121 2206 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
2207 (flags & G_ARRAY) ? OPf_WANT_LIST :
2208 OPf_WANT_SCALAR);
6e72f9df 2209 if (flags & G_KEEPERR)
2210 myop.op_flags |= OPf_SPECIAL;
4633a7c4 2211
dedbcade
DM		 2212 /* fail now; otherwise we could fail after the JMPENV_PUSH but
2213 * before a PUSHEVAL, which corrupts the stack after a croak */
2214 TAINT_PROPER("eval_sv()");
2215
14dd3ad8 2216 JMPENV_PUSH(ret);
6224f72b
GS		 2217 switch (ret) {
2218 case 0:
14dd3ad8
GS		 2219 redo_body:
2220 call_body((OP*)&myop,TRUE);
312caa8e
CS		 2221 retval = PL_stack_sp - (PL_stack_base + oldmark);
2222 if (!(flags & G_KEEPERR))
2223 sv_setpv(ERRSV,"");
4633a7c4 2224 break;
6224f72b 2225 case 1:
f86702cc 2226 STATUS_ALL_FAILURE;
4633a7c4 2227 /* FALL THROUGH */
6224f72b 2228 case 2:
4633a7c4 2229 /* my_exit() was called */
3280af22 2230 PL_curstash = PL_defstash;
4633a7c4 2231 FREETMPS;
14dd3ad8 2232 JMPENV_POP;
cc3604b1 2233 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
cea2e8a9 2234 Perl_croak(aTHX_ "Callback called exit");
f86702cc 2235 my_exit_jump();
4633a7c4 2236 /* NOTREACHED */
6224f72b 2237 case 3:
3280af22 2238 if (PL_restartop) {
533c011a 2239 PL_op = PL_restartop;
3280af22 2240 PL_restartop = 0;
312caa8e 2241 goto redo_body;
4633a7c4 2242 }
3280af22 2243 PL_stack_sp = PL_stack_base + oldmark;
4633a7c4
LW		 2244 if (flags & G_ARRAY)
2245 retval = 0;
2246 else {
2247 retval = 1;
3280af22 2248 *++PL_stack_sp = &PL_sv_undef;
4633a7c4 2249 }
312caa8e 2250 break;
4633a7c4
LW		 2251 }
2252
14dd3ad8 2253 JMPENV_POP;
4633a7c4 2254 if (flags & G_DISCARD) {
3280af22 2255 PL_stack_sp = PL_stack_base + oldmark;
4633a7c4
LW		 2256 retval = 0;
2257 FREETMPS;
2258 LEAVE;
2259 }
533c011a 2260 PL_op = oldop;
4633a7c4
LW		 2261 return retval;
2262}
2263
954c1994
GS		 2264/*
2265=for apidoc p||eval_pv
2266
2267Tells Perl to C<eval> the given string and return an SV* result.
2268
2269=cut
2270*/
2271
137443ea 2272SV*
864dbfa3 2273Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
137443ea 2274{
2275 dSP;
2276 SV* sv = newSVpv(p, 0);
2277
864dbfa3 2278 eval_sv(sv, G_SCALAR);
137443ea 2279 SvREFCNT_dec(sv);
2280
2281 SPAGAIN;
2282 sv = POPs;
2283 PUTBACK;
2284
2d8e6c8d
GS		 2285 if (croak_on_error && SvTRUE(ERRSV)) {
2286 STRLEN n_a;
cea2e8a9 2287 Perl_croak(aTHX_ SvPVx(ERRSV, n_a));
2d8e6c8d 2288 }
137443ea 2289
2290 return sv;
2291}
2292
4633a7c4
LW		 2293/* Require a module. */
2294
954c1994 2295/*
ccfc67b7
JH		 2296=head1 Embedding Functions
2297
954c1994
GS		 2298=for apidoc p||require_pv
2299
7d3fb230
BS		 2300Tells Perl to C<require> the file named by the string argument. It is
2301analogous to the Perl code C<eval "require '$file'">. It's even
2307c6d0 2302implemented that way; consider using load_module instead.
954c1994 2303
7d3fb230 2304=cut */
954c1994 2305
4633a7c4 2306void
864dbfa3 2307Perl_require_pv(pTHX_ const char *pv)
4633a7c4 2308{
d3acc0f7
JP		 2309 SV* sv;
2310 dSP;
e788e7d3 2311 PUSHSTACKi(PERLSI_REQUIRE);
d3acc0f7
JP		 2312 PUTBACK;
2313 sv = sv_newmortal();
4633a7c4
LW		 2314 sv_setpv(sv, "require '");
2315 sv_catpv(sv, pv);
2316 sv_catpv(sv, "'");
864dbfa3 2317 eval_sv(sv, G_DISCARD);
d3acc0f7
JP		 2318 SPAGAIN;
2319 POPSTACK;
79072805
LW		 2320}
2321
79072805 2322void
864dbfa3 2323Perl_magicname(pTHX_ char *sym, char *name, I32 namlen)
79072805
LW		 2324{
2325 register GV *gv;
2326
155aba94 2327 if ((gv = gv_fetchpv(sym,TRUE, SVt_PV)))
14befaf4 2328 sv_magic(GvSV(gv), (SV*)gv, PERL_MAGIC_sv, name, namlen);
79072805
LW		 2329}
2330
76e3520e 2331STATIC void
cea2e8a9 2332S_usage(pTHX_ char *name) /* XXX move this out into a module ? */
4633a7c4 2333{
ab821d7f 2334 /* This message really ought to be max 23 lines.
75c72d73 2335 * Removed -h because the user already knows that option. Others? */
fb73857a 2336
76e3520e 2337 static char *usage_msg[] = {
fb73857a 2338"-0[octal] specify record separator (\\0, if no argument)",
2339"-a autosplit mode with -n or -p (splits $_ into @F)",
fb3560ee 2340"-C[number/list] enables the listed Unicode features",
1950ee41 2341"-c check syntax only (runs BEGIN and CHECK blocks)",
aac3bd0d
GS		 2342"-d[:debugger] run program under debugger",
2343"-D[number/list] set debugging flags (argument is a bit mask or alphabets)",
90490ea3 2344"-e program one line of program (several -e's allowed, omit programfile)",
aac3bd0d
GS		 2345"-F/pattern/ split() pattern for -a switch (//'s are optional)",
2346"-i[extension] edit <> files in place (makes backup if extension supplied)",
2347"-Idirectory specify @INC/#include directory (several -I's allowed)",
fb73857a 2348"-l[octal] enable line ending processing, specifies line terminator",
aac3bd0d
GS		 2349"-[mM][-]module execute `use/no module...' before executing program",
2350"-n assume 'while (<>) { ... }' loop around program",
2351"-p assume loop like -n but print line also, like sed",
2352"-P run program through C preprocessor before compilation",
2353"-s enable rudimentary parsing for switches after programfile",
2354"-S look for programfile using PATH environment variable",
9cbc33e8 2355"-t enable tainting warnings",
90490ea3 2356"-T enable tainting checks",
aac3bd0d 2357"-u dump core after parsing program",
fb73857a 2358"-U allow unsafe operations",
aac3bd0d
GS		 2359"-v print version, subversion (includes VERY IMPORTANT perl info)",
2360"-V[:variable] print configuration summary (or a single Config.pm variable)",
2361"-w enable many useful warnings (RECOMMENDED)",
3c0facb2 2362"-W enable all warnings",
fb73857a 2363"-x[directory] strip off text before #!perl line and perhaps cd to directory",
90490ea3 2364"-X disable all warnings",
fb73857a 2365"\n",
2366NULL
2367};
76e3520e 2368 char **p = usage_msg;
fb73857a 2369
b0e47665
GS		 2370 PerlIO_printf(PerlIO_stdout(),
2371 "\nUsage: %s [switches] [--] [programfile] [arguments]",
2372 name);
fb73857a 2373 while (*p)
b0e47665 2374 PerlIO_printf(PerlIO_stdout(), "\n %s", *p++);
4633a7c4
LW		 2375}
2376
b4ab917c
DM		 2377/* convert a string of -D options (or digits) into an int.
2378 * sets *s to point to the char after the options */
2379
2380#ifdef DEBUGGING
2381int
ddcf8bc1 2382Perl_get_debug_opts(pTHX_ char **s, bool givehelp)
b4ab917c 2383{
e6e64d9b
JC		 2384 static char *usage_msgd[] = {
2385 " Debugging flag values: (see also -d)",
2386 " p Tokenizing and parsing (with v, displays parse stack)",
3679267a 2387 " s Stack snapshots (with v, displays all stacks)",
e6e64d9b
JC		 2388 " l Context (loop) stack processing",
2389 " t Trace execution",
2390 " o Method and overloading resolution",
2391 " c String/numeric conversions",
2392 " P Print profiling info, preprocessor command for -P, source file input state",
2393 " m Memory allocation",
2394 " f Format processing",
2395 " r Regular expression parsing and execution",
2396 " x Syntax tree dump",
3679267a 2397 " u Tainting checks",
e6e64d9b
JC		 2398 " H Hash dump -- usurps values()",
2399 " X Scratchpad allocation",
2400 " D Cleaning up",
2401 " S Thread synchronization",
2402 " T Tokenising",
2403 " R Include reference counts of dumped variables (eg when using -Ds)",
2404 " J Do not s,t,P-debug (Jump over) opcodes within package DB",
2405 " v Verbose: use in conjunction with other flags",
2406 " C Copy On Write",
2407 " A Consistency checks on internal structures",
3679267a 2408 " q quiet - currently only suppresses the 'EXECUTING' message",
e6e64d9b
JC		 2409 NULL
2410 };
b4ab917c
DM		 2411 int i = 0;
2412 if (isALPHA(**s)) {
2413 /* if adding extra options, remember to update DEBUG_MASK */
ecae49c0 2414 static char debopts[] = "psltocPmfrxu HXDSTRJvCAq";
b4ab917c
DM		 2415
2416 for (; isALNUM(**s); (*s)++) {
2417 char *d = strchr(debopts,**s);
2418 if (d)
2419 i |= 1 << (d - debopts);
2420 else if (ckWARN_d(WARN_DEBUGGING))
e6e64d9b
JC		 2421 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
2422 "invalid option -D%c, use -D'' to see choices\n", **s);
b4ab917c
DM		 2423 }
2424 }
e6e64d9b 2425 else if (isDIGIT(**s)) {
b4ab917c
DM		 2426 i = atoi(*s);
2427 for (; isALNUM(**s); (*s)++) ;
2428 }
ddcf8bc1 2429 else if (givehelp) {
e6e64d9b
JC		 2430 char **p = usage_msgd;
2431 while (*p) PerlIO_printf(PerlIO_stdout(), "%s\n", *p++);
2432 }
b4ab917c
DM		 2433# ifdef EBCDIC
2434 if ((i & DEBUG_p_FLAG) && ckWARN_d(WARN_DEBUGGING))
2435 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
2436 "-Dp not implemented on this platform\n");
2437# endif
2438 return i;
2439}
2440#endif
2441
79072805
LW		 2442/* This routine handles any switches that can be given during run */
2443
2444char *
864dbfa3 2445Perl_moreswitches(pTHX_ char *s)
79072805 2446{
ba210ebe 2447 STRLEN numlen;
84c133a0 2448 UV rschar;
79072805
LW		 2449
2450 switch (*s) {
2451 case '0':
a863c7d1 2452 {
f2095865
JH		 2453 I32 flags = 0;
2454
2455 SvREFCNT_dec(PL_rs);
2456 if (s[1] == 'x' && s[2]) {
2457 char *e;
2458 U8 *tmps;
2459
2460 for (s += 2, e = s; *e; e++);
2461 numlen = e - s;
2462 flags = PERL_SCAN_SILENT_ILLDIGIT;
2463 rschar = (U32)grok_hex(s, &numlen, &flags, NULL);
2464 if (s + numlen < e) {
2465 rschar = 0; /* Grandfather -0xFOO as -0 -xFOO. */
2466 numlen = 0;
2467 s--;
2468 }
2469 PL_rs = newSVpvn("", 0);
c5661c80 2470 SvGROW(PL_rs, (STRLEN)(UNISKIP(rschar) + 1));
f2095865
JH		 2471 tmps = (U8*)SvPVX(PL_rs);
2472 uvchr_to_utf8(tmps, rschar);
2473 SvCUR_set(PL_rs, UNISKIP(rschar));
2474 SvUTF8_on(PL_rs);
2475 }
2476 else {
2477 numlen = 4;
2478 rschar = (U32)grok_oct(s, &numlen, &flags, NULL);
2479 if (rschar & ~((U8)~0))
2480 PL_rs = &PL_sv_undef;
2481 else if (!rschar && numlen >= 2)
2482 PL_rs = newSVpvn("", 0);
2483 else {
2484 char ch = (char)rschar;
2485 PL_rs = newSVpvn(&ch, 1);
2486 }
2487 }
800633c3 2488 sv_setsv(get_sv("/", TRUE), PL_rs);
f2095865 2489 return s + numlen;
a863c7d1 2490 }
46487f74 2491 case 'C':
a05d7ebb
JH		 2492 s++;
2493 PL_unicode = parse_unicode_opts(&s);
46487f74 2494 return s;
2304df62 2495 case 'F':
3280af22 2496 PL_minus_F = TRUE;
ebce5377
RGS		 2497 PL_splitstr = ++s;
2498 while (*s && !isSPACE(*s)) ++s;
2499 *s = '\0';
2500 PL_splitstr = savepv(PL_splitstr);
2304df62 2501 return s;
79072805 2502 case 'a':
3280af22 2503 PL_minus_a = TRUE;
79072805
LW		 2504 s++;
2505 return s;
2506 case 'c':
3280af22 2507 PL_minus_c = TRUE;
79072805
LW		 2508 s++;
2509 return s;
2510 case 'd':
bbce6d69 2511 forbid_setid("-d");
4633a7c4 2512 s++;
2cbb2ee1
RGS		 2513
2514 /* -dt indicates to the debugger that threads will be used */
2515 if (*s == 't' && !isALNUM(s[1])) {
2516 ++s;
2517 my_setenv("PERL5DB_THREADED", "1");
2518 }
2519
70c94a19
RR		 2520 /* The following permits -d:Mod to accepts arguments following an =
2521 in the fashion that -MSome::Mod does. */
2522 if (*s == ':' || *s == '=') {
2523 char *start;
2524 SV *sv;
2525 sv = newSVpv("use Devel::", 0);
2526 start = ++s;
2527 /* We now allow -d:Module=Foo,Bar */
2528 while(isALNUM(*s) || *s==':') ++s;
2529 if (*s != '=')
2530 sv_catpv(sv, start);
2531 else {
2532 sv_catpvn(sv, start, s-start);
2533 sv_catpv(sv, " split(/,/,q{");
2534 sv_catpv(sv, ++s);
3d27e215 2535 sv_catpv(sv, "})");
70c94a19 2536 }
4633a7c4 2537 s += strlen(s);
70c94a19 2538 my_setenv("PERL5DB", SvPV(sv, PL_na));
4633a7c4 2539 }
ed094faf 2540 if (!PL_perldb) {
3280af22 2541 PL_perldb = PERLDB_ALL;
a0d0e21e 2542 init_debugger();
ed094faf 2543 }
79072805
LW		 2544 return s;
2545 case 'D':
0453d815 2546 {
79072805 2547#ifdef DEBUGGING
bbce6d69 2548 forbid_setid("-D");
b4ab917c 2549 s++;
ddcf8bc1 2550 PL_debug = get_debug_opts(&s, 1) | DEBUG_TOP_FLAG;
12a43e32 2551#else /* !DEBUGGING */
0453d815 2552 if (ckWARN_d(WARN_DEBUGGING))
9014280d 2553 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
e6e64d9b 2554 "Recompile perl with -DDEBUGGING to use -D switch (did you mean -d ?)\n");
a0d0e21e 2555 for (s++; isALNUM(*s); s++) ;
79072805
LW		 2556#endif
2557 /*SUPPRESS 530*/
2558 return s;
0453d815 2559 }
4633a7c4 2560 case 'h':
ac27b0f5 2561 usage(PL_origargv[0]);
7ca617d0 2562 my_exit(0);
79072805 2563 case 'i':
3280af22
NIS		 2564 if (PL_inplace)
2565 Safefree(PL_inplace);
c030f24b
GH		 2566#if defined(__CYGWIN__) /* do backup extension automagically */
2567 if (*(s+1) == '\0') {
2568 PL_inplace = savepv(".bak");
2569 return s+1;
2570 }
2571#endif /* __CYGWIN__ */
3280af22 2572 PL_inplace = savepv(s+1);
79072805 2573 /*SUPPRESS 530*/
3280af22 2574 for (s = PL_inplace; *s && !isSPACE(*s); s++) ;
7b8d334a 2575 if (*s) {
fb73857a 2576 *s++ = '\0';
7b8d334a
GS		 2577 if (*s == '-') /* Additional switches on #! line. */
2578 s++;
2579 }
fb73857a 2580 return s;
4e49a025 2581 case 'I': /* -I handled both here and in parse_body() */
bbce6d69 2582 forbid_setid("-I");
fb73857a 2583 ++s;
2584 while (*s && isSPACE(*s))
2585 ++s;
2586 if (*s) {
774d564b 2587 char *e, *p;
0df16ed7
GS		 2588 p = s;
2589 /* ignore trailing spaces (possibly followed by other switches) */
2590 do {
2591 for (e = p; *e && !isSPACE(*e); e++) ;
2592 p = e;
2593 while (isSPACE(*p))
2594 p++;
2595 } while (*p && *p != '-');
2596 e = savepvn(s, e-s);
88fe16b2 2597 incpush(e, TRUE, TRUE, FALSE, FALSE);
0df16ed7
GS		 2598 Safefree(e);
2599 s = p;
2600 if (*s == '-')
2601 s++;
79072805
LW		 2602 }
2603 else
a67e862a 2604 Perl_croak(aTHX_ "No directory specified for -I");
fb73857a 2605 return s;
79072805 2606 case 'l':
3280af22 2607 PL_minus_l = TRUE;
79072805 2608 s++;
7889fe52
NIS		 2609 if (PL_ors_sv) {
2610 SvREFCNT_dec(PL_ors_sv);
2611 PL_ors_sv = Nullsv;
2612 }
79072805 2613 if (isDIGIT(*s)) {
53305cf1 2614 I32 flags = 0;
7889fe52 2615 PL_ors_sv = newSVpvn("\n",1);
53305cf1
NC		 2616 numlen = 3 + (*s == '0');
2617 *SvPVX(PL_ors_sv) = (char)grok_oct(s, &numlen, &flags, NULL);
79072805
LW		 2618 s += numlen;
2619 }
2620 else {
8bfdd7d9 2621 if (RsPARA(PL_rs)) {
7889fe52
NIS		 2622 PL_ors_sv = newSVpvn("\n\n",2);
2623 }
2624 else {
8bfdd7d9 2625 PL_ors_sv = newSVsv(PL_rs);
c07a80fd 2626 }
79072805
LW		 2627 }
2628 return s;
06492da6
SF		 2629 case 'A':
2630 forbid_setid("-A");
930366bd
RGS		 2631 if (!PL_preambleav)
2632 PL_preambleav = newAV();
06492da6 2633 if (*++s) {
3d27e215
LM		 2634 SV *sv = newSVpv("use assertions::activate split(/,/,q", 0);
2635 sv_catpvn(sv, "\0", 1); /* Use NUL as q//-delimiter. */
06492da6 2636 sv_catpv(sv,s);
3d27e215 2637 sv_catpvn(sv, "\0)", 2);
06492da6 2638 s+=strlen(s);
06492da6
SF		 2639 av_push(PL_preambleav, sv);
2640 }
2641 else
930366bd 2642 av_push(PL_preambleav, newSVpvn("use assertions::activate",24));
06492da6 2643 return s;
1a30305b 2644 case 'M':
bbce6d69 2645 forbid_setid("-M"); /* XXX ? */
1a30305b 2646 /* FALL THROUGH */
2647 case 'm':
bbce6d69 2648 forbid_setid("-m"); /* XXX ? */
1a30305b 2649 if (*++s) {
a5f75d66 2650 char *start;
11343788 2651 SV *sv;
a5f75d66
AD		 2652 char *use = "use ";
2653 /* -M-foo == 'no foo' */
2654 if (*s == '-') { use = "no "; ++s; }
11343788 2655 sv = newSVpv(use,0);
a5f75d66 2656 start = s;
1a30305b 2657 /* We allow -M'Module qw(Foo Bar)' */
c07a80fd 2658 while(isALNUM(*s) || *s==':') ++s;
2659 if (*s != '=') {
11343788 2660 sv_catpv(sv, start);
c07a80fd 2661 if (*(start-1) == 'm') {
2662 if (*s != '\0')
cea2e8a9 2663 Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
11343788 2664 sv_catpv( sv, " ()");
c07a80fd 2665 }
2666 } else {
6df41af2 2667 if (s == start)
be98fb35
GS		 2668 Perl_croak(aTHX_ "Module name required with -%c option",
2669 s[-1]);
11343788 2670 sv_catpvn(sv, start, s-start);
3d27e215
LM		 2671 sv_catpv(sv, " split(/,/,q");
2672 sv_catpvn(sv, "\0)", 1); /* Use NUL as q//-delimiter. */
11343788 2673 sv_catpv(sv, ++s);
3d27e215 2674 sv_catpvn(sv, "\0)", 2);
c07a80fd 2675 }
1a30305b 2676 s += strlen(s);
5c831c24 2677 if (!PL_preambleav)
3280af22
NIS		 2678 PL_preambleav = newAV();
2679 av_push(PL_preambleav, sv);
1a30305b 2680 }
2681 else
9e81e6a1 2682 Perl_croak(aTHX_ "Missing argument to -%c", *(s-1));
1a30305b 2683 return s;
79072805 2684 case 'n':
3280af22 2685 PL_minus_n = TRUE;
79072805
LW		 2686 s++;
2687 return s;
2688 case 'p':
3280af22 2689 PL_minus_p = TRUE;
79072805
LW		 2690 s++;
2691 return s;
2692 case 's':
bbce6d69 2693 forbid_setid("-s");
3280af22 2694 PL_doswitches = TRUE;
79072805
LW		 2695 s++;
2696 return s;
6537fe72
MS		 2697 case 't':
2698 if (!PL_tainting)
22f7c9c9 2699 TOO_LATE_FOR('t');
6537fe72
MS		 2700 s++;
2701 return s;
463ee0b2 2702 case 'T':
3280af22 2703 if (!PL_tainting)
22f7c9c9 2704 TOO_LATE_FOR('T');
463ee0b2
LW		 2705 s++;
2706 return s;
79072805 2707 case 'u':
bf4acbe4
GS		 2708#ifdef MACOS_TRADITIONAL
2709 Perl_croak(aTHX_ "Believe me, you don't want to use \"-u\" on a Macintosh");
2710#endif
3280af22 2711 PL_do_undump = TRUE;
79072805
LW		 2712 s++;
2713 return s;
2714 case 'U':
3280af22 2715 PL_unsafe = TRUE;
79072805
LW		 2716 s++;
2717 return s;
2718 case 'v':
d7aa5382
JP		 2719 if (!sv_derived_from(PL_patchlevel, "version"))
2720 (void *)upg_version(PL_patchlevel);
8e9464f1 2721#if !defined(DGUX)
b0e47665 2722 PerlIO_printf(PerlIO_stdout(),
014ead4b 2723 Perl_form(aTHX_ "\nThis is perl, v%"SVf" built for %s",
d7aa5382
JP		 2724 vstringify(PL_patchlevel),
2725 ARCHNAME));
8e9464f1
JH		 2726#else /* DGUX */
2727/* Adjust verbose output as in the perl that ships with the DG/UX OS from EMC */
2728 PerlIO_printf(PerlIO_stdout(),
014ead4b 2729 Perl_form(aTHX_ "\nThis is perl, v%"SVf"\n",
d7aa5382 2730 vstringify(PL_patchlevel)));
8e9464f1
JH		 2731 PerlIO_printf(PerlIO_stdout(),
2732 Perl_form(aTHX_ " built under %s at %s %s\n",
2733 OSNAME, __DATE__, __TIME__));
2734 PerlIO_printf(PerlIO_stdout(),
2735 Perl_form(aTHX_ " OS Specific Release: %s\n",
40a39f85 2736 OSVERS));
8e9464f1
JH		 2737#endif /* !DGUX */
2738
fb73857a 2739#if defined(LOCAL_PATCH_COUNT)
2740 if (LOCAL_PATCH_COUNT > 0)
b0e47665
GS		 2741 PerlIO_printf(PerlIO_stdout(),
2742 "\n(with %d registered patch%s, "
2743 "see perl -V for more detail)",
2744 (int)LOCAL_PATCH_COUNT,
2745 (LOCAL_PATCH_COUNT!=1) ? "es" : "");
a5f75d66 2746#endif
1a30305b 2747
b0e47665 2748 PerlIO_printf(PerlIO_stdout(),
359b00fe 2749 "\n\nCopyright 1987-2005, Larry Wall\n");
eae9c151
JH		 2750#ifdef MACOS_TRADITIONAL
2751 PerlIO_printf(PerlIO_stdout(),
be3c0a43 2752 "\nMac OS port Copyright 1991-2002, Matthias Neeracher;\n"
03765510 2753 "maintained by Chris Nandor\n");
eae9c151 2754#endif
79072805 2755#ifdef MSDOS
b0e47665
GS		 2756 PerlIO_printf(PerlIO_stdout(),
2757 "\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
55497cff 2758#endif
2759#ifdef DJGPP
b0e47665
GS		 2760 PerlIO_printf(PerlIO_stdout(),
2761 "djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n"
2762 "djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
4633a7c4 2763#endif
79072805 2764#ifdef OS2
b0e47665
GS		 2765 PerlIO_printf(PerlIO_stdout(),
2766 "\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
be3c0a43 2767 "Version 5 port Copyright (c) 1994-2002, Andreas Kaiser, Ilya Zakharevich\n");
79072805 2768#endif
79072805 2769#ifdef atarist
b0e47665
GS		 2770 PerlIO_printf(PerlIO_stdout(),
2771 "atariST series port, ++jrb bammi@cadence.com\n");
79072805 2772#endif
a3f9223b 2773#ifdef __BEOS__
b0e47665
GS		 2774 PerlIO_printf(PerlIO_stdout(),
2775 "BeOS port Copyright Tom Spindler, 1997-1999\n");
a3f9223b 2776#endif
1d84e8df 2777#ifdef MPE
b0e47665 2778 PerlIO_printf(PerlIO_stdout(),
e583a879 2779 "MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-2003\n");
1d84e8df 2780#endif
9d116dd7 2781#ifdef OEMVS
b0e47665
GS		 2782 PerlIO_printf(PerlIO_stdout(),
2783 "MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
9d116dd7 2784#endif
495c5fdc 2785#ifdef __VOS__
b0e47665 2786 PerlIO_printf(PerlIO_stdout(),
94efb9fb 2787 "Stratus VOS port by Paul.Green@stratus.com, 1997-2002\n");
495c5fdc 2788#endif
092bebab 2789#ifdef __OPEN_VM
b0e47665
GS		 2790 PerlIO_printf(PerlIO_stdout(),
2791 "VM/ESA port by Neale Ferguson, 1998-1999\n");
092bebab 2792#endif
a1a0e61e 2793#ifdef POSIX_BC
b0e47665
GS		 2794 PerlIO_printf(PerlIO_stdout(),
2795 "BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
a1a0e61e 2796#endif
61ae2fbf 2797#ifdef __MINT__
b0e47665
GS		 2798 PerlIO_printf(PerlIO_stdout(),
2799 "MiNT port by Guido Flohr, 1997-1999\n");
61ae2fbf 2800#endif
f83d2536 2801#ifdef EPOC
b0e47665 2802 PerlIO_printf(PerlIO_stdout(),
be3c0a43 2803 "EPOC port by Olaf Flebbe, 1999-2002\n");
f83d2536 2804#endif
e1caacb4 2805#ifdef UNDER_CE
b475b3e6
JH		 2806 PerlIO_printf(PerlIO_stdout(),"WINCE port by Rainer Keuchel, 2001-2002\n");
2807 PerlIO_printf(PerlIO_stdout(),"Built on " __DATE__ " " __TIME__ "\n\n");
e1caacb4
JH		 2808 wce_hitreturn();
2809#endif
baed7233
DL		 2810#ifdef BINARY_BUILD_NOTICE
2811 BINARY_BUILD_NOTICE;
2812#endif
b0e47665
GS		 2813 PerlIO_printf(PerlIO_stdout(),
2814 "\n\
79072805 2815Perl may be copied only under the terms of either the Artistic License or the\n\
3d6f292d 2816GNU General Public License, which may be found in the Perl 5 source kit.\n\n\
95103687
GS		 2817Complete documentation for Perl, including FAQ lists, should be found on\n\
2818this system using `man perl' or `perldoc perl'. If you have access to the\n\
c9e30dd8 2819Internet, point your browser at http://www.perl.org/, the Perl Home Page.\n\n");
7ca617d0 2820 my_exit(0);
79072805 2821 case 'w':
599cee73 2822 if (! (PL_dowarn & G_WARN_ALL_MASK))
ac27b0f5 2823 PL_dowarn |= G_WARN_ON;
599cee73
PM		 2824 s++;
2825 return s;
2826 case 'W':
ac27b0f5 2827 PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
317ea90d
MS		 2828 if (!specialWARN(PL_compiling.cop_warnings))
2829 SvREFCNT_dec(PL_compiling.cop_warnings);
d3a7d8c7 2830 PL_compiling.cop_warnings = pWARN_ALL ;
599cee73
PM		 2831 s++;
2832 return s;
2833 case 'X':
ac27b0f5 2834 PL_dowarn = G_WARN_ALL_OFF;
317ea90d
MS		 2835 if (!specialWARN(PL_compiling.cop_warnings))
2836 SvREFCNT_dec(PL_compiling.cop_warnings);
d3a7d8c7 2837 PL_compiling.cop_warnings = pWARN_NONE ;
79072805
LW		 2838 s++;
2839 return s;
a0d0e21e 2840 case '*':
79072805
LW		 2841 case ' ':
2842 if (s[1] == '-') /* Additional switches on #! line. */
2843 return s+2;
2844 break;
a0d0e21e 2845 case '-':
79072805 2846 case 0:
51882d45 2847#if defined(WIN32) || !defined(PERL_STRICT_CR)
a868473f
NIS		 2848 case '\r':
2849#endif
79072805
LW		 2850 case '\n':
2851 case '\t':
2852 break;
aa689395 2853#ifdef ALTERNATE_SHEBANG
2854 case 'S': /* OS/2 needs -S on "extproc" line. */
2855 break;
2856#endif
a0d0e21e 2857 case 'P':
3280af22 2858 if (PL_preprocess)
a0d0e21e
LW		 2859 return s+1;
2860 /* FALL THROUGH */
79072805 2861 default:
cea2e8a9 2862 Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
79072805
LW		 2863 }
2864 return Nullch;
2865}
2866
2867/* compliments of Tom Christiansen */
2868
2869/* unexec() can be found in the Gnu emacs distribution */
ee580363 2870/* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
79072805
LW		 2871
2872void
864dbfa3 2873Perl_my_unexec(pTHX)
79072805
LW		 2874{
2875#ifdef UNEXEC
46fc3d4c 2876 SV* prog;
2877 SV* file;
ee580363 2878 int status = 1;
79072805
LW		 2879 extern int etext;
2880
ee580363 2881 prog = newSVpv(BIN_EXP, 0);
46fc3d4c 2882 sv_catpv(prog, "/perl");
6b88bc9c 2883 file = newSVpv(PL_origfilename, 0);
46fc3d4c 2884 sv_catpv(file, ".perldump");
79072805 2885
ee580363
GS		 2886 unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
2887 /* unexec prints msg to stderr in case of failure */
6ad3d225 2888 PerlProc_exit(status);
79072805 2889#else
a5f75d66
AD		 2890# ifdef VMS
2891# include <lib$routines.h>
2892 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
aa689395 2893# else
79072805 2894 ABORT(); /* for use with undump */
aa689395 2895# endif
a5f75d66 2896#endif
79072805
LW		 2897}
2898
cb68f92d
GS		 2899/* initialize curinterp */
2900STATIC void
cea2e8a9 2901S_init_interp(pTHX)
cb68f92d
GS		 2902{
2903
acfe0abc
GS		 2904#ifdef MULTIPLICITY
2905# define PERLVAR(var,type)
2906# define PERLVARA(var,n,type)
2907# if defined(PERL_IMPLICIT_CONTEXT)
2908# if defined(USE_5005THREADS)
2909# define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
c5be433b 2910# define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
acfe0abc
GS		 2911# else /* !USE_5005THREADS */
2912# define PERLVARI(var,type,init) aTHX->var = init;
2913# define PERLVARIC(var,type,init) aTHX->var = init;
2914# endif /* USE_5005THREADS */
3967c732 2915# else
acfe0abc
GS		 2916# define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
2917# define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
066ef5b5 2918# endif
acfe0abc
GS		 2919# include "intrpvar.h"
2920# ifndef USE_5005THREADS
2921# include "thrdvar.h"
2922# endif
2923# undef PERLVAR
2924# undef PERLVARA
2925# undef PERLVARI
2926# undef PERLVARIC
2927#else
2928# define PERLVAR(var,type)
2929# define PERLVARA(var,n,type)
2930# define PERLVARI(var,type,init) PL_##var = init;
2931# define PERLVARIC(var,type,init) PL_##var = init;
2932# include "intrpvar.h"
2933# ifndef USE_5005THREADS
2934# include "thrdvar.h"
2935# endif
2936# undef PERLVAR
2937# undef PERLVARA
2938# undef PERLVARI
2939# undef PERLVARIC
cb68f92d
GS		 2940#endif
2941
cb68f92d
GS		 2942}
2943
76e3520e 2944STATIC void
cea2e8a9 2945S_init_main_stash(pTHX)
79072805 2946{
463ee0b2 2947 GV *gv;
6e72f9df 2948
3280af22 2949 PL_curstash = PL_defstash = newHV();
79cb57f6 2950 PL_curstname = newSVpvn("main",4);
adbc6bb1
LW		 2951 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
2952 SvREFCNT_dec(GvHV(gv));
3280af22 2953 GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);
463ee0b2 2954 SvREADONLY_on(gv);
ff5bdd37 2955 HvNAME(PL_defstash) = savepvn("main", 4);
3280af22
NIS		 2956 PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
2957 GvMULTI_on(PL_incgv);
2958 PL_hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */
2959 GvMULTI_on(PL_hintgv);
2960 PL_defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
2961 PL_errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
2962 GvMULTI_on(PL_errgv);
2963 PL_replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */
2964 GvMULTI_on(PL_replgv);
cea2e8a9 2965 (void)Perl_form(aTHX_ "%240s",""); /* Preallocate temp - for immediate signals. */
38a03e6e
MB		 2966 sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
2967 sv_setpvn(ERRSV, "", 0);
3280af22 2968 PL_curstash = PL_defstash;
11faa288 2969 CopSTASH_set(&PL_compiling, PL_defstash);
ed094faf 2970 PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
3280af22 2971 PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
4633a7c4 2972 /* We must init $/ before switches are processed. */
864dbfa3 2973 sv_setpvn(get_sv("/", TRUE), "\n", 1);
79072805
LW		 2974}
2975
ae3f3efd 2976/* PSz 18 Nov 03 fdscript now global but do not change prototype */
76e3520e 2977STATIC void
c5cccb17 2978S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv)
79072805 2979{
ae3f3efd 2980#ifndef IAMSUID
1b24ed4b
MS		 2981 char *quote;
2982 char *code;
2983 char *cpp_discard_flag;
2984 char *perl;
ae3f3efd 2985#endif
1b24ed4b 2986
ae3f3efd
PS		 2987 PL_fdscript = -1;
2988 PL_suidscript = -1;
79072805 2989
3280af22 2990 if (PL_e_script) {
ff5bdd37 2991 PL_origfilename = savepvn("-e", 2);
96436eeb 2992 }
6c4ab083
GS		 2993 else {
2994 /* if find_script() returns, it returns a malloc()-ed value */
3280af22 2995 PL_origfilename = scriptname = find_script(scriptname, dosearch, NULL, 1);
6c4ab083
GS		 2996
2997 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
2998 char *s = scriptname + 8;
ae3f3efd 2999 PL_fdscript = atoi(s);
6c4ab083
GS		 3000 while (isDIGIT(*s))
3001 s++;
3002 if (*s) {
ae3f3efd
PS		 3003 /* PSz 18 Feb 04
3004 * Tell apart "normal" usage of fdscript, e.g.
3005 * with bash on FreeBSD:
3006 * perl <( echo '#!perl -DA'; echo 'print "$0\n"')
3007 * from usage in suidperl.
3008 * Does any "normal" usage leave garbage after the number???
3009 * Is it a mistake to use a similar /dev/fd/ construct for
3010 * suidperl?
3011 */
3012 PL_suidscript = 1;
3013 /* PSz 20 Feb 04
3014 * Be supersafe and do some sanity-checks.
3015 * Still, can we be sure we got the right thing?
3016 */
3017 if (*s != '/') {
3018 Perl_croak(aTHX_ "Wrong syntax (suid) fd script name \"%s\"\n", s);
3019 }
3020 if (! *(s+1)) {
3021 Perl_croak(aTHX_ "Missing (suid) fd script name\n");
3022 }
6c4ab083 3023 scriptname = savepv(s + 1);
3280af22
NIS		 3024 Safefree(PL_origfilename);
3025 PL_origfilename = scriptname;
6c4ab083
GS		 3026 }
3027 }
3028 }
3029
05ec9bb3 3030 CopFILE_free(PL_curcop);
57843af0 3031 CopFILE_set(PL_curcop, PL_origfilename);
770526c1 3032 if (*PL_origfilename == '-' && PL_origfilename[1] == '\0')
79072805 3033 scriptname = "";
ae3f3efd
PS		 3034 if (PL_fdscript >= 0) {
3035 PL_rsfp = PerlIO_fdopen(PL_fdscript,PERL_SCRIPT_MODE);
1b24ed4b
MS		 3036# if defined(HAS_FCNTL) && defined(F_SETFD)
3037 if (PL_rsfp)
3038 /* ensure close-on-exec */
3039 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);
3040# endif
96436eeb 3041 }
ae3f3efd
PS		 3042#ifdef IAMSUID
3043 else {
86207487
NC		 3044 Perl_croak(aTHX_ "sperl needs fd script\n"
3045 "You should not call sperl directly; do you need to "
3046 "change a #! line\nfrom sperl to perl?\n");
3047
ae3f3efd
PS		 3048/* PSz 11 Nov 03
3049 * Do not open (or do other fancy stuff) while setuid.
3050 * Perl does the open, and hands script to suidperl on a fd;
3051 * suidperl only does some checks, sets up UIDs and re-execs
3052 * perl with that fd as it has always done.
3053 */
3054 }
3055 if (PL_suidscript != 1) {
3056 Perl_croak(aTHX_ "suidperl needs (suid) fd script\n");
3057 }
3058#else /* IAMSUID */
3280af22 3059 else if (PL_preprocess) {
46fc3d4c 3060 char *cpp_cfg = CPPSTDIN;
79cb57f6 3061 SV *cpp = newSVpvn("",0);
46fc3d4c 3062 SV *cmd = NEWSV(0,0);
3063
ae58f265
JH		 3064 if (cpp_cfg[0] == 0) /* PERL_MICRO? */
3065 Perl_croak(aTHX_ "Can't run with cpp -P with CPPSTDIN undefined");
46fc3d4c 3066 if (strEQ(cpp_cfg, "cppstdin"))
cea2e8a9 3067 Perl_sv_catpvf(aTHX_ cpp, "%s/", BIN_EXP);
46fc3d4c 3068 sv_catpv(cpp, cpp_cfg);
79072805 3069
1b24ed4b
MS		 3070# ifndef VMS
3071 sv_catpvn(sv, "-I", 2);
3072 sv_catpv(sv,PRIVLIB_EXP);
3073# endif
46fc3d4c 3074
14953ddc
MB		 3075 DEBUG_P(PerlIO_printf(Perl_debug_log,
3076 "PL_preprocess: scriptname=\"%s\", cpp=\"%s\", sv=\"%s\", CPPMINUS=\"%s\"\n",
3077 scriptname, SvPVX (cpp), SvPVX (sv), CPPMINUS));
1b24ed4b
MS		 3078
3079# if defined(MSDOS) || defined(WIN32) || defined(VMS)
3080 quote = "\"";
3081# else
3082 quote = "'";
3083# endif
3084
3085# ifdef VMS
3086 cpp_discard_flag = "";
3087# else
3088 cpp_discard_flag = "-C";
3089# endif
3090
3091# ifdef OS2
3092 perl = os2_execname(aTHX);
3093# else
3094 perl = PL_origargv[0];
3095# endif
3096
3097
3098 /* This strips off Perl comments which might interfere with
62375a60
NIS		 3099 the C pre-processor, including #!. #line directives are
3100 deliberately stripped to avoid confusion with Perl's version
1b24ed4b
MS		 3101 of #line. FWP played some golf with it so it will fit
3102 into VMS's 255 character buffer.
3103 */
3104 if( PL_doextract )
3105 code = "(1../^#!.*perl/i)|/^\\s*#(?!\\s*((ifn?|un)def|(el|end)?if|define|include|else|error|pragma)\\b)/||!($|=1)||print";
3106 else
3107 code = "/^\\s*#(?!\\s*((ifn?|un)def|(el|end)?if|define|include|else|error|pragma)\\b)/||!($|=1)||print";
3108
3109 Perl_sv_setpvf(aTHX_ cmd, "\
3110%s -ne%s%s%s %s | %"SVf" %s %"SVf" %s",
62375a60 3111 perl, quote, code, quote, scriptname, cpp,
1b24ed4b
MS		 3112 cpp_discard_flag, sv, CPPMINUS);
3113
3280af22 3114 PL_doextract = FALSE;
0a6c758d 3115
62375a60
NIS		 3116 DEBUG_P(PerlIO_printf(Perl_debug_log,
3117 "PL_preprocess: cmd=\"%s\"\n",
0a6c758d
MS		 3118 SvPVX(cmd)));
3119
3280af22 3120 PL_rsfp = PerlProc_popen(SvPVX(cmd), "r");
46fc3d4c 3121 SvREFCNT_dec(cmd);
3122 SvREFCNT_dec(cpp);
79072805
LW		 3123 }
3124 else if (!*scriptname) {
bbce6d69 3125 forbid_setid("program input from stdin");
3280af22 3126 PL_rsfp = PerlIO_stdin();
79072805 3127 }
96436eeb 3128 else {
3280af22 3129 PL_rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
1b24ed4b
MS		 3130# if defined(HAS_FCNTL) && defined(F_SETFD)
3131 if (PL_rsfp)
3132 /* ensure close-on-exec */
3133 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);
3134# endif
96436eeb 3135 }
ae3f3efd 3136#endif /* IAMSUID */
3280af22 3137 if (!PL_rsfp) {
447218f8 3138 /* PSz 16 Sep 03 Keep neat error message */
fa3aa65a
JC		 3139 Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
3140 CopFILE(PL_curcop), Strerror(errno));
13281fa4 3141 }
79072805 3142}
8d063cd8 3143
7b89560d
JH		 3144/* Mention
3145 * I_SYSSTATVFS HAS_FSTATVFS
3146 * I_SYSMOUNT
c890dc6c 3147 * I_STATFS HAS_FSTATFS HAS_GETFSSTAT
7b89560d
JH		 3148 * I_MNTENT HAS_GETMNTENT HAS_HASMNTOPT
3149 * here so that metaconfig picks them up. */
3150
104d25b7 3151#ifdef IAMSUID
864dbfa3 3152STATIC int
e688b231 3153S_fd_on_nosuid_fs(pTHX_ int fd)
104d25b7 3154{
ae3f3efd
PS		 3155/* PSz 27 Feb 04
3156 * We used to do this as "plain" user (after swapping UIDs with setreuid);
3157 * but is needed also on machines without setreuid.
3158 * Seems safe enough to run as root.
3159 */
0545a864
JH		 3160 int check_okay = 0; /* able to do all the required sys/libcalls */
3161 int on_nosuid = 0; /* the fd is on a nosuid fs */
ae3f3efd
PS		 3162 /* PSz 12 Nov 03
3163 * Need to check noexec also: nosuid might not be set, the average
3164 * sysadmin would say that nosuid is irrelevant once he sets noexec.
3165 */
3166 int on_noexec = 0; /* the fd is on a noexec fs */
3167
104d25b7 3168/*
ad27e871 3169 * Preferred order: fstatvfs(), fstatfs(), ustat()+getmnt(), getmntent().
e688b231 3170 * fstatvfs() is UNIX98.
0545a864 3171 * fstatfs() is 4.3 BSD.
ad27e871 3172 * ustat()+getmnt() is pre-4.3 BSD.
0545a864
JH		 3173 * getmntent() is O(number-of-mounted-filesystems) and can hang on
3174 * an irrelevant filesystem while trying to reach the right one.
104d25b7
JH		 3175 */
3176
6439433f
JH		 3177#undef FD_ON_NOSUID_CHECK_OKAY /* found the syscalls to do the check? */
3178
3179# if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
3180 defined(HAS_FSTATVFS)
3181# define FD_ON_NOSUID_CHECK_OKAY
104d25b7 3182 struct statvfs stfs;
6439433f 3183
104d25b7
JH		 3184 check_okay = fstatvfs(fd, &stfs) == 0;
3185 on_nosuid = check_okay && (stfs.f_flag & ST_NOSUID);
ae3f3efd
PS		 3186#ifdef ST_NOEXEC
3187 /* ST_NOEXEC certainly absent on AIX 5.1, and doesn't seem to be documented
3188 on platforms where it is present. */
3189 on_noexec = check_okay && (stfs.f_flag & ST_NOEXEC);
3190#endif
6439433f 3191# endif /* fstatvfs */
ac27b0f5 3192
6439433f
JH		 3193# if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
3194 defined(PERL_MOUNT_NOSUID) && \
ae3f3efd 3195 defined(PERL_MOUNT_NOEXEC) && \
6439433f
JH		 3196 defined(HAS_FSTATFS) && \
3197 defined(HAS_STRUCT_STATFS) && \
3198 defined(HAS_STRUCT_STATFS_F_FLAGS)
3199# define FD_ON_NOSUID_CHECK_OKAY
e688b231 3200 struct statfs stfs;
6439433f 3201
104d25b7 3202 check_okay = fstatfs(fd, &stfs) == 0;
104d25b7 3203 on_nosuid = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID);
ae3f3efd 3204 on_noexec = check_okay && (stfs.f_flags & PERL_MOUNT_NOEXEC);
6439433f
JH		 3205# endif /* fstatfs */
3206
3207# if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
3208 defined(PERL_MOUNT_NOSUID) && \
ae3f3efd 3209 defined(PERL_MOUNT_NOEXEC) && \
6439433f
JH		 3210 defined(HAS_FSTAT) && \
3211 defined(HAS_USTAT) && \
3212 defined(HAS_GETMNT) && \
3213 defined(HAS_STRUCT_FS_DATA) && \
3214 defined(NOSTAT_ONE)
3215# define FD_ON_NOSUID_CHECK_OKAY
c623ac67 3216 Stat_t fdst;
6439433f 3217
0545a864 3218 if (fstat(fd, &fdst) == 0) {
6439433f
JH		 3219 struct ustat us;
3220 if (ustat(fdst.st_dev, &us) == 0) {
3221 struct fs_data fsd;
3222 /* NOSTAT_ONE here because we're not examining fields which
3223 * vary between that case and STAT_ONE. */
ad27e871 3224 if (getmnt((int*)0, &fsd, (int)0, NOSTAT_ONE, us.f_fname) == 0) {
6439433f
JH		 3225 size_t cmplen = sizeof(us.f_fname);
3226 if (sizeof(fsd.fd_req.path) < cmplen)
3227 cmplen = sizeof(fsd.fd_req.path);
3228 if (strnEQ(fsd.fd_req.path, us.f_fname, cmplen) &&
3229 fdst.st_dev == fsd.fd_req.dev) {
3230 check_okay = 1;
3231 on_nosuid = fsd.fd_req.flags & PERL_MOUNT_NOSUID;
ae3f3efd 3232 on_noexec = fsd.fd_req.flags & PERL_MOUNT_NOEXEC;
6439433f
JH		 3233 }
3234 }
3235 }
3236 }
0545a864 3237 }
6439433f
JH		 3238# endif /* fstat+ustat+getmnt */
3239
3240# if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
3241 defined(HAS_GETMNTENT) && \
3242 defined(HAS_HASMNTOPT) && \
ae3f3efd
PS		 3243 defined(MNTOPT_NOSUID) && \
3244 defined(MNTOPT_NOEXEC)
6439433f
JH		 3245# define FD_ON_NOSUID_CHECK_OKAY
3246 FILE *mtab = fopen("/etc/mtab", "r");
3247 struct mntent *entry;
c623ac67 3248 Stat_t stb, fsb;
104d25b7
JH		 3249
3250 if (mtab && (fstat(fd, &stb) == 0)) {
6439433f
JH		 3251 while (entry = getmntent(mtab)) {
3252 if (stat(entry->mnt_dir, &fsb) == 0
3253 && fsb.st_dev == stb.st_dev)
3254 {
3255 /* found the filesystem */
3256 check_okay = 1;
3257 if (hasmntopt(entry, MNTOPT_NOSUID))
3258 on_nosuid = 1;
ae3f3efd
PS		 3259 if (hasmntopt(entry, MNTOPT_NOEXEC))
3260 on_noexec = 1;
6439433f
JH		 3261 break;
3262 } /* A single fs may well fail its stat(). */
3263 }
104d25b7
JH		 3264 }
3265 if (mtab)
6439433f
JH		 3266 fclose(mtab);
3267# endif /* getmntent+hasmntopt */
0545a864 3268
ac27b0f5 3269 if (!check_okay)
ae3f3efd
PS		 3270 Perl_croak(aTHX_ "Can't check filesystem of script \"%s\" for nosuid/noexec", PL_origfilename);
3271 if (on_nosuid)
3272 Perl_croak(aTHX_ "Setuid script \"%s\" on nosuid filesystem", PL_origfilename);
3273 if (on_noexec)
3274 Perl_croak(aTHX_ "Setuid script \"%s\" on noexec filesystem", PL_origfilename);
3275 return ((!check_okay) || on_nosuid || on_noexec);
104d25b7
JH		 3276}
3277#endif /* IAMSUID */
3278
76e3520e 3279STATIC void
c5cccb17 3280S_validate_suid(pTHX_ char *validarg, char *scriptname)
79072805 3281{
155aba94 3282#ifdef IAMSUID
ae3f3efd
PS		 3283 /* int which; */
3284#endif /* IAMSUID */
96436eeb 3285
13281fa4
LW		 3286 /* do we need to emulate setuid on scripts? */
3287
3288 /* This code is for those BSD systems that have setuid #! scripts disabled
3289 * in the kernel because of a security problem. Merely defining DOSUID
3290 * in perl will not fix that problem, but if you have disabled setuid
3291 * scripts in the kernel, this will attempt to emulate setuid and setgid
3292 * on scripts that have those now-otherwise-useless bits set. The setuid
27e2fb84
LW		 3293 * root version must be called suidperl or sperlN.NNN. If regular perl
3294 * discovers that it has opened a setuid script, it calls suidperl with
3295 * the same argv that it had. If suidperl finds that the script it has
3296 * just opened is NOT setuid root, it sets the effective uid back to the
3297 * uid. We don't just make perl setuid root because that loses the
3298 * effective uid we had before invoking perl, if it was different from the
3299 * uid.
ae3f3efd
PS		 3300 * PSz 27 Feb 04
3301 * Description/comments above do not match current workings:
3302 * suidperl must be hardlinked to sperlN.NNN (that is what we exec);
3303 * suidperl called with script open and name changed to /dev/fd/N/X;
3304 * suidperl croaks if script is not setuid;
3305 * making perl setuid would be a huge security risk (and yes, that
3306 * would lose any euid we might have had).
13281fa4
LW		 3307 *
3308 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
3309 * be defined in suidperl only. suidperl must be setuid root. The
3310 * Configure script will set this up for you if you want it.
3311 */
a687059c 3312
13281fa4 3313#ifdef DOSUID
6e72f9df 3314 char *s, *s2;
a0d0e21e 3315
b28d0864 3316 if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0) /* normal stat is insecure */
cea2e8a9 3317 Perl_croak(aTHX_ "Can't stat script \"%s\"",PL_origfilename);
ae3f3efd 3318 if (PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
79072805 3319 I32 len;
2d8e6c8d 3320 STRLEN n_a;
13281fa4 3321
a687059c 3322#ifdef IAMSUID
ae3f3efd
PS		 3323 if (PL_fdscript < 0 || PL_suidscript != 1)
3324 Perl_croak(aTHX_ "Need (suid) fdscript in suidperl\n"); /* We already checked this */
3325 /* PSz 11 Nov 03
3326 * Since the script is opened by perl, not suidperl, some of these
3327 * checks are superfluous. Leaving them in probably does not lower
3328 * security(?!).
3329 */
3330 /* PSz 27 Feb 04
3331 * Do checks even for systems with no HAS_SETREUID.
3332 * We used to swap, then re-swap UIDs with
3333#ifdef HAS_SETREUID
3334 if (setreuid(PL_euid,PL_uid) < 0
3335 || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
3336 Perl_croak(aTHX_ "Can't swap uid and euid");
3337#endif
3338#ifdef HAS_SETREUID
3339 if (setreuid(PL_uid,PL_euid) < 0
3340 || PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid)
3341 Perl_croak(aTHX_ "Can't reswap uid and euid");
3342#endif
3343 */
3344
a687059c
LW		 3345 /* On this access check to make sure the directories are readable,
3346 * there is actually a small window that the user could use to make
3347 * filename point to an accessible directory. So there is a faint
3348 * chance that someone could execute a setuid script down in a
3349 * non-accessible directory. I don't know what to do about that.
3350 * But I don't think it's too important. The manual lies when
3351 * it says access() is useful in setuid programs.
ae3f3efd
PS		 3352 *
3353 * So, access() is pretty useless... but not harmful... do anyway.
a687059c 3354 */
e57400b1 3355 if (PerlLIO_access(CopFILE(PL_curcop),1)) { /*double check*/
ae3f3efd 3356 Perl_croak(aTHX_ "Can't access() script\n");
e57400b1 3357 }
ae3f3efd 3358
a687059c
LW		 3359 /* If we can swap euid and uid, then we can determine access rights
3360 * with a simple stat of the file, and then compare device and
3361 * inode to make sure we did stat() on the same file we opened.
3362 * Then we just have to make sure he or she can execute it.
ae3f3efd
PS		 3363 *
3364 * PSz 24 Feb 04
3365 * As the script is opened by perl, not suidperl, we do not need to
3366 * care much about access rights.
3367 *
3368 * The 'script changed' check is needed, or we can get lied to
3369 * about $0 with e.g.
3370 * suidperl /dev/fd/4//bin/x 4<setuidscript
3371 * Without HAS_SETREUID, is it safe to stat() as root?
3372 *
3373 * Are there any operating systems that pass /dev/fd/xxx for setuid
3374 * scripts, as suggested/described in perlsec(1)? Surely they do not
3375 * pass the script name as we do, so the "script changed" test would
3376 * fail for them... but we never get here with
3377 * SETUID_SCRIPTS_ARE_SECURE_NOW defined.
3378 *
3379 * This is one place where we must "lie" about return status: not
3380 * say if the stat() failed. We are doing this as root, and could
3381 * be tricked into reporting existence or not of files that the
3382 * "plain" user cannot even see.
a687059c
LW		 3383 */
3384 {
c623ac67 3385 Stat_t tmpstatbuf;
ae3f3efd
PS		 3386 if (PerlLIO_stat(CopFILE(PL_curcop),&tmpstatbuf) < 0 ||
3387 tmpstatbuf.st_dev != PL_statbuf.st_dev ||
b28d0864 3388 tmpstatbuf.st_ino != PL_statbuf.st_ino) {
ae3f3efd 3389 Perl_croak(aTHX_ "Setuid script changed\n");
a687059c 3390 }
ae3f3efd 3391
a687059c 3392 }
ae3f3efd
PS		 3393 if (!cando(S_IXUSR,FALSE,&PL_statbuf)) /* can real uid exec? */
3394 Perl_croak(aTHX_ "Real UID cannot exec script\n");
3395
3396 /* PSz 27 Feb 04
3397 * We used to do this check as the "plain" user (after swapping
3398 * UIDs). But the check for nosuid and noexec filesystem is needed,
3399 * and should be done even without HAS_SETREUID. (Maybe those
3400 * operating systems do not have such mount options anyway...)
3401 * Seems safe enough to do as root.
3402 */
3403#if !defined(NO_NOSUID_CHECK)
3404 if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp))) {
3405 Perl_croak(aTHX_ "Setuid script on nosuid or noexec filesystem\n");
3406 }
3407#endif
a687059c
LW		 3408#endif /* IAMSUID */
3409
e57400b1 3410 if (!S_ISREG(PL_statbuf.st_mode)) {
ae3f3efd 3411 Perl_croak(aTHX_ "Setuid script not plain file\n");
e57400b1 3412 }
b28d0864 3413 if (PL_statbuf.st_mode & S_IWOTH)
cea2e8a9 3414 Perl_croak(aTHX_ "Setuid/gid script is writable by world");
6b88bc9c 3415 PL_doswitches = FALSE; /* -s is insecure in suid */
ae3f3efd 3416 /* PSz 13 Nov 03 But -s was caught elsewhere ... so unsetting it here is useless(?!) */
57843af0 3417 CopLINE_inc(PL_curcop);
6b88bc9c 3418 if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch ||
2d8e6c8d 3419 strnNE(SvPV(PL_linestr,n_a),"#!",2) ) /* required even on Sys V */
cea2e8a9 3420 Perl_croak(aTHX_ "No #! line");
2d8e6c8d 3421 s = SvPV(PL_linestr,n_a)+2;
ae3f3efd
PS		 3422 /* PSz 27 Feb 04 */
3423 /* Sanity check on line length */
3424 if (strlen(s) < 1 || strlen(s) > 4000)
3425 Perl_croak(aTHX_ "Very long #! line");
3426 /* Allow more than a single space after #! */
3427 while (isSPACE(*s)) s++;
3428 /* Sanity check on buffer end */
3429 while ((*s) && !isSPACE(*s)) s++;
2d8e6c8d 3430 for (s2 = s; (s2 > SvPV(PL_linestr,n_a)+2 &&
3792a11b
NC		 3431 (isDIGIT(s2[-1]) || s2[-1] == '.' || s2[-1] == '_'
3432 || s2[-1] == '-')); s2--) ;
ae3f3efd
PS		 3433 /* Sanity check on buffer start */
3434 if ( (s2-4 < SvPV(PL_linestr,n_a)+2 || strnNE(s2-4,"perl",4)) &&
3435 (s-9 < SvPV(PL_linestr,n_a)+2 || strnNE(s-9,"perl",4)) )
cea2e8a9 3436 Perl_croak(aTHX_ "Not a perl script");
a687059c 3437 while (*s == ' ' || *s == '\t') s++;
13281fa4
LW		 3438 /*
3439 * #! arg must be what we saw above. They can invoke it by
3440 * mentioning suidperl explicitly, but they may not add any strange
3441 * arguments beyond what #! says if they do invoke suidperl that way.
3442 */
ae3f3efd
PS		 3443 /*
3444 * The way validarg was set up, we rely on the kernel to start
3445 * scripts with argv[1] set to contain all #! line switches (the
3446 * whole line).
3447 */
3448 /*
3449 * Check that we got all the arguments listed in the #! line (not
3450 * just that there are no extraneous arguments). Might not matter
3451 * much, as switches from #! line seem to be acted upon (also), and
3452 * so may be checked and trapped in perl. But, security checks must
3453 * be done in suidperl and not deferred to perl. Note that suidperl
3454 * does not get around to parsing (and checking) the switches on
3455 * the #! line (but execs perl sooner).
3456 * Allow (require) a trailing newline (which may be of two
3457 * characters on some architectures?) (but no other trailing
3458 * whitespace).
3459 */
13281fa4
LW		 3460 len = strlen(validarg);
3461 if (strEQ(validarg," PHOOEY ") ||
ae3f3efd
PS		 3462 strnNE(s,validarg,len) || !isSPACE(s[len]) ||
3463 !(strlen(s) == len+1 || (strlen(s) == len+2 && isSPACE(s[len+1]))))
cea2e8a9 3464 Perl_croak(aTHX_ "Args must match #! line");
a687059c
LW		 3465
3466#ifndef IAMSUID
ae3f3efd
PS		 3467 if (PL_fdscript < 0 &&
3468 PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
b28d0864
NIS		 3469 PL_euid == PL_statbuf.st_uid)
3470 if (!PL_do_undump)
cea2e8a9 3471 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
11fb1898 3472FIX YOUR KERNEL, OR PUT A C WRAPPER AROUND THIS SCRIPT!\n");
a687059c 3473#endif /* IAMSUID */
13281fa4 3474
ae3f3efd
PS		 3475 if (PL_fdscript < 0 &&
3476 PL_euid) { /* oops, we're not the setuid root perl */
3477 /* PSz 18 Feb 04
3478 * When root runs a setuid script, we do not go through the same
3479 * steps of execing sperl and then perl with fd scripts, but
3480 * simply set up UIDs within the same perl invocation; so do
3481 * not have the same checks (on options, whatever) that we have
3482 * for plain users. No problem really: would have to be a script
3483 * that does not actually work for plain users; and if root is
3484 * foolish and can be persuaded to run such an unsafe script, he
3485 * might run also non-setuid ones, and deserves what he gets.
3486 *
3487 * Or, we might drop the PL_euid check above (and rely just on
3488 * PL_fdscript to avoid loops), and do the execs
3489 * even for root.
3490 */
13281fa4 3491#ifndef IAMSUID
ae3f3efd
PS		 3492 int which;
3493 /* PSz 11 Nov 03
3494 * Pass fd script to suidperl.
3495 * Exec suidperl, substituting fd script for scriptname.
3496 * Pass script name as "subdir" of fd, which perl will grok;
3497 * in fact will use that to distinguish this from "normal"
3498 * usage, see comments above.
3499 */
3500 PerlIO_rewind(PL_rsfp);
3501 PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0); /* just in case rewind didn't */
3502 /* PSz 27 Feb 04 Sanity checks on scriptname */
3503 if ((!scriptname) || (!*scriptname) ) {
3504 Perl_croak(aTHX_ "No setuid script name\n");
3505 }
3506 if (*scriptname == '-') {
3507 Perl_croak(aTHX_ "Setuid script name may not begin with dash\n");
3508 /* Or we might confuse it with an option when replacing
3509 * name in argument list, below (though we do pointer, not
3510 * string, comparisons).
3511 */
3512 }
3513 for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;
3514 if (!PL_origargv[which]) {
3515 Perl_croak(aTHX_ "Can't change argv to have fd script\n");
3516 }
3517 PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s",
3518 PerlIO_fileno(PL_rsfp), PL_origargv[which]));
3519#if defined(HAS_FCNTL) && defined(F_SETFD)
3520 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0); /* ensure no close-on-exec */
3521#endif
b35112e7 3522 PERL_FPU_PRE_EXEC
a7cb1f99 3523 PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, BIN_EXP,
273cf8d1
GS		 3524 (int)PERL_REVISION, (int)PERL_VERSION,
3525 (int)PERL_SUBVERSION), PL_origargv);
b35112e7 3526 PERL_FPU_POST_EXEC
ae3f3efd
PS		 3527#endif /* IAMSUID */
3528 Perl_croak(aTHX_ "Can't do setuid (cannot exec sperl)\n");
13281fa4
LW		 3529 }
3530
b28d0864 3531 if (PL_statbuf.st_mode & S_ISGID && PL_statbuf.st_gid != PL_egid) {
ae3f3efd
PS		 3532/* PSz 26 Feb 04
3533 * This seems back to front: we try HAS_SETEGID first; if not available
3534 * then try HAS_SETREGID; as a last chance we try HAS_SETRESGID. May be OK
3535 * in the sense that we only want to set EGID; but are there any machines
3536 * with either of the latter, but not the former? Same with UID, later.
3537 */
fe14fcc3 3538#ifdef HAS_SETEGID
b28d0864 3539 (void)setegid(PL_statbuf.st_gid);
a687059c 3540#else
fe14fcc3 3541#ifdef HAS_SETREGID
b28d0864 3542 (void)setregid((Gid_t)-1,PL_statbuf.st_gid);
85e6fe83
LW		 3543#else
3544#ifdef HAS_SETRESGID
b28d0864 3545 (void)setresgid((Gid_t)-1,PL_statbuf.st_gid,(Gid_t)-1);
a687059c 3546#else
b28d0864 3547 PerlProc_setgid(PL_statbuf.st_gid);
a687059c
LW		 3548#endif
3549#endif
85e6fe83 3550#endif
b28d0864 3551 if (PerlProc_getegid() != PL_statbuf.st_gid)
cea2e8a9 3552 Perl_croak(aTHX_ "Can't do setegid!\n");
83025b21 3553 }
b28d0864
NIS		 3554 if (PL_statbuf.st_mode & S_ISUID) {
3555 if (PL_statbuf.st_uid != PL_euid)
fe14fcc3 3556#ifdef HAS_SETEUID
b28d0864 3557 (void)seteuid(PL_statbuf.st_uid); /* all that for this */
a687059c 3558#else
fe14fcc3 3559#ifdef HAS_SETREUID
b28d0864 3560 (void)setreuid((Uid_t)-1,PL_statbuf.st_uid);
85e6fe83
LW		 3561#else
3562#ifdef HAS_SETRESUID
b28d0864 3563 (void)setresuid((Uid_t)-1,PL_statbuf.st_uid,(Uid_t)-1);
a687059c 3564#else
b28d0864 3565 PerlProc_setuid(PL_statbuf.st_uid);
a687059c
LW		 3566#endif
3567#endif
85e6fe83