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
[perl #34976] substr uses utf8 length cache incorrectly
[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);
07409e01 189 return (PerlInterpreter *) 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"))) {
e1ec3a88 362 const int i = atoi(s);
5f05dabc 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
fd0854ff
DM		 830 " refcnt=%"UVuf pTHX__FORMAT "\n"
831 "\tallocated at %s:%d %s %s%s\n",
832 sv, sv->sv_flags, sv->sv_refcnt pTHX__VALUE,
833 sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
834 sv->sv_debug_line,
835 sv->sv_debug_inpad ? "for" : "by",
836 sv->sv_debug_optype ?
837 PL_op_name[sv->sv_debug_optype]: "(none)",
838 sv->sv_debug_cloned ? " (cloned)" : ""
839 );
eba0f806
DM		 840 }
841 }
842 }
843 }
844#endif
bf9cdc68 845 PL_sv_count = 0;
eba0f806
DM		 846
847
56a2bab7 848#if defined(PERLIO_LAYERS)
3a1ee7e8
NIS		 849 /* No more IO - including error messages ! */
850 PerlIO_cleanup(aTHX);
851#endif
852
9f4bd222
NIS		 853 /* sv_undef needs to stay immortal until after PerlIO_cleanup
854 as currently layers use it rather than Nullsv as a marker
855 for no arg - and will try and SvREFCNT_dec it.
856 */
857 SvREFCNT(&PL_sv_undef) = 0;
858 SvREADONLY_off(&PL_sv_undef);
859
3280af22 860 Safefree(PL_origfilename);
bf9cdc68 861 PL_origfilename = Nullch;
3280af22 862 Safefree(PL_reg_start_tmp);
bf9cdc68
RG		 863 PL_reg_start_tmp = (char**)NULL;
864 PL_reg_start_tmpl = 0;
5c5e4c24
IZ		 865 if (PL_reg_curpm)
866 Safefree(PL_reg_curpm);
82ba1be6 867 Safefree(PL_reg_poscache);
dd28f7bb 868 free_tied_hv_pool();
3280af22 869 Safefree(PL_op_mask);
cf36064f 870 Safefree(PL_psig_ptr);
bf9cdc68 871 PL_psig_ptr = (SV**)NULL;
cf36064f 872 Safefree(PL_psig_name);
bf9cdc68 873 PL_psig_name = (SV**)NULL;
2c2666fc 874 Safefree(PL_bitcount);
bf9cdc68 875 PL_bitcount = Nullch;
ce08f86c 876 Safefree(PL_psig_pend);
bf9cdc68
RG		 877 PL_psig_pend = (int*)NULL;
878 PL_formfeed = Nullsv;
879 Safefree(PL_ofmt);
880 PL_ofmt = Nullch;
6e72f9df 881 nuke_stacks();
bf9cdc68
RG		 882 PL_tainting = FALSE;
883 PL_taint_warn = FALSE;
3280af22 884 PL_hints = 0; /* Reset hints. Should hints be per-interpreter ? */
bf9cdc68 885 PL_debug = 0;
ac27b0f5 886
a0d0e21e 887 DEBUG_P(debprofdump());
d33b2eba 888
e5dd39fc 889#ifdef USE_REENTRANT_API
10bc17b6 890 Perl_reentrant_free(aTHX);
e5dd39fc
AB		 891#endif
892
612f20c3
GS		 893 sv_free_arenas();
894
fc36a67e 895 /* As the absolutely last thing, free the non-arena SV for mess() */
896
3280af22 897 if (PL_mess_sv) {
9c63abab
GS		 898 /* it could have accumulated taint magic */
899 if (SvTYPE(PL_mess_sv) >= SVt_PVMG) {
900 MAGIC* mg;
901 MAGIC* moremagic;
902 for (mg = SvMAGIC(PL_mess_sv); mg; mg = moremagic) {
903 moremagic = mg->mg_moremagic;
14befaf4
DM		 904 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global
905 && mg->mg_len >= 0)
9c63abab
GS		 906 Safefree(mg->mg_ptr);
907 Safefree(mg);
908 }
909 }
fc36a67e 910 /* we know that type >= SVt_PV */
0c34ef67 911 SvOOK_off(PL_mess_sv);
3280af22
NIS		 912 Safefree(SvPVX(PL_mess_sv));
913 Safefree(SvANY(PL_mess_sv));
914 Safefree(PL_mess_sv);
915 PL_mess_sv = Nullsv;
fc36a67e 916 }
31d77e54 917 return STATUS_NATIVE_EXPORT;
79072805
LW		 918}
919
954c1994
GS		 920/*
921=for apidoc perl_free
922
923Releases a Perl interpreter. See L<perlembed>.
924
925=cut
926*/
927
79072805 928void
0cb96387 929perl_free(pTHXx)
79072805 930{
acfe0abc 931#if defined(WIN32) || defined(NETWARE)
ce3e5b80 932# if defined(PERL_IMPLICIT_SYS)
acfe0abc
GS		 933# ifdef NETWARE
934 void *host = nw_internal_host;
935# else
936 void *host = w32_internal_host;
937# endif
ce3e5b80 938 PerlMem_free(aTHXx);
acfe0abc 939# ifdef NETWARE
011f1a1a 940 nw_delete_internal_host(host);
acfe0abc
GS		 941# else
942 win32_delete_internal_host(host);
943# endif
1c0ca838
GS		 944# else
945 PerlMem_free(aTHXx);
946# endif
acfe0abc
GS		 947#else
948 PerlMem_free(aTHXx);
76e3520e 949#endif
79072805
LW		 950}
951
aebd1ac7
GA		 952#if defined(USE_5005THREADS) || defined(USE_ITHREADS)
953/* provide destructors to clean up the thread key when libperl is unloaded */
954#ifndef WIN32 /* handled during DLL_PROCESS_DETACH in win32/perllib.c */
955
956#if defined(__hpux) && !defined(__GNUC__)
957#pragma fini "perl_fini"
958#endif
959
960#if defined(__GNUC__) && defined(__attribute__)
961/* want to make sure __attribute__ works here even
962 * for -Dd_attribut=undef builds.
963 */
964#undef __attribute__
965#endif
966
967static void __attribute__((destructor))
968perl_fini()
969{
970 if (PL_curinterp)
971 FREE_THREAD_KEY;
972}
973
974#endif /* WIN32 */
975#endif /* THREADS */
976
4b556e6c 977void
864dbfa3 978Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr)
4b556e6c 979{
3280af22
NIS		 980 Renew(PL_exitlist, PL_exitlistlen+1, PerlExitListEntry);
981 PL_exitlist[PL_exitlistlen].fn = fn;
982 PL_exitlist[PL_exitlistlen].ptr = ptr;
983 ++PL_exitlistlen;
4b556e6c
JD		 984}
985
56cf6df8
RGS		 986#ifdef HAS_PROCSELFEXE
987/* This is a function so that we don't hold on to MAXPATHLEN
988 bytes of stack longer than necessary
989 */
990STATIC void
e1ec3a88 991S_procself_val(pTHX_ SV *sv, const char *arg0)
56cf6df8
RGS		 992{
993 char buf[MAXPATHLEN];
994 int len = readlink(PROCSELFEXE_PATH, buf, sizeof(buf) - 1);
995
996 /* On Playstation2 Linux V1.0 (kernel 2.2.1) readlink(/proc/self/exe)
997 includes a spurious NUL which will cause $^X to fail in system
998 or backticks (this will prevent extensions from being built and
999 many tests from working). readlink is not meant to add a NUL.
1000 Normal readlink works fine.
1001 */
1002 if (len > 0 && buf[len-1] == '\0') {
1003 len--;
1004 }
1005
1006 /* FreeBSD's implementation is acknowledged to be imperfect, sometimes
1007 returning the text "unknown" from the readlink rather than the path
1008 to the executable (or returning an error from the readlink). Any valid
1009 path has a '/' in it somewhere, so use that to validate the result.
1010 See http://www.freebsd.org/cgi/query-pr.cgi?pr=35703
1011 */
1012 if (len > 0 && memchr(buf, '/', len)) {
1013 sv_setpvn(sv,buf,len);
1014 }
1015 else {
1016 sv_setpv(sv,arg0);
1017 }
1018}
1019#endif /* HAS_PROCSELFEXE */
b7975bdd
NC		 1020
1021STATIC void
1022S_set_caret_X(pTHX) {
1023 GV* tmpgv = gv_fetchpv("\030",TRUE, SVt_PV); /* $^X */
1024 if (tmpgv) {
1025#ifdef HAS_PROCSELFEXE
1026 S_procself_val(aTHX_ GvSV(tmpgv), PL_origargv[0]);
1027#else
1028#ifdef OS2
1029 sv_setpv(GvSV(tmpgv), os2_execname(aTHX));
1030#else
1031 sv_setpv(GvSV(tmpgv),PL_origargv[0]);
1032#endif
1033#endif
1034 }
1035}
1036
954c1994
GS		 1037/*
1038=for apidoc perl_parse
1039
1040Tells a Perl interpreter to parse a Perl script. See L<perlembed>.
1041
1042=cut
1043*/
1044
79072805 1045int
0cb96387 1046perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env)
8d063cd8 1047{
6224f72b 1048 I32 oldscope;
6224f72b 1049 int ret;
db36c5a1 1050 dJMPENV;
8d063cd8 1051
a687059c
LW		 1052#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
1053#ifdef IAMSUID
1054#undef IAMSUID
cea2e8a9 1055 Perl_croak(aTHX_ "suidperl is no longer needed since the kernel can now execute\n\
a687059c 1056setuid perl scripts securely.\n");
ae3f3efd 1057#endif /* IAMSUID */
a687059c
LW		 1058#endif
1059
b0891165
JH		 1060#if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT)
1061 /* [perl #22371] Algorimic Complexity Attack on Perl 5.6.1, 5.8.0
103dd899 1062 * This MUST be done before any hash stores or fetches take place.
008fb0c0
NC		 1063 * If you set PL_rehash_seed (and assumedly also PL_rehash_seed_set)
1064 * yourself, it is your responsibility to provide a good random seed!
830b38bd 1065 * You can also define PERL_HASH_SEED in compile time, see hv.h. */
008fb0c0
NC		 1066 if (!PL_rehash_seed_set)
1067 PL_rehash_seed = get_hash_seed();
b0891165 1068 {
bed60192
JH		 1069 char *s = PerlEnv_getenv("PERL_HASH_SEED_DEBUG");
1070
1071 if (s) {
1072 int i = atoi(s);
1073
1074 if (i == 1)
1075 PerlIO_printf(Perl_debug_log, "HASH_SEED = %"UVuf"\n",
008fb0c0 1076 PL_rehash_seed);
bed60192 1077 }
b0891165
JH		 1078 }
1079#endif /* #if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT) */
1080
3280af22 1081 PL_origargc = argc;
e2975953 1082 PL_origargv = argv;
a0d0e21e 1083
54bfe034 1084 {
3cb9023d
JH		 1085 /* Set PL_origalen be the sum of the contiguous argv[]
1086 * elements plus the size of the env in case that it is
e9137a8e 1087 * contiguous with the argv[]. This is used in mg.c:Perl_magic_set()
3cb9023d
JH		 1088 * as the maximum modifiable length of $0. In the worst case
1089 * the area we are able to modify is limited to the size of
43c32782 1090 * the original argv[0]. (See below for 'contiguous', though.)
3cb9023d 1091 * --jhi */
e1ec3a88 1092 const char *s = NULL;
54bfe034 1093 int i;
7d8e7db3
JH		 1094 UV mask =
1095 ~(UV)(PTRSIZE == 4 ? 3 : PTRSIZE == 8 ? 7 : PTRSIZE == 16 ? 15 : 0);
43c32782
JH		 1096 /* Do the mask check only if the args seem like aligned. */
1097 UV aligned =
1098 (mask < ~(UV)0) && ((PTR2UV(argv[0]) & mask) == PTR2UV(argv[0]));
1099
1100 /* See if all the arguments are contiguous in memory. Note
1101 * that 'contiguous' is a loose term because some platforms
1102 * align the argv[] and the envp[]. If the arguments look
1103 * like non-aligned, assume that they are 'strictly' or
1104 * 'traditionally' contiguous. If the arguments look like
1105 * aligned, we just check that they are within aligned
1106 * PTRSIZE bytes. As long as no system has something bizarre
1107 * like the argv[] interleaved with some other data, we are
1108 * fine. (Did I just evoke Murphy's Law?) --jhi */
c8941eeb
JH		 1109 if (PL_origargv && PL_origargc >= 1 && (s = PL_origargv[0])) {
1110 while (*s) s++;
1111 for (i = 1; i < PL_origargc; i++) {
1112 if ((PL_origargv[i] == s + 1
43c32782 1113#ifdef OS2
c8941eeb 1114 || PL_origargv[i] == s + 2
43c32782 1115#endif
c8941eeb
JH		 1116 )
1117 ||
1118 (aligned &&
1119 (PL_origargv[i] > s &&
1120 PL_origargv[i] <=
1121 INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)))
1122 )
1123 {
1124 s = PL_origargv[i];
1125 while (*s) s++;
1126 }
1127 else
1128 break;
54bfe034 1129 }
54bfe034 1130 }
3cb9023d 1131 /* Can we grab env area too to be used as the area for $0? */
43c32782
JH		 1132 if (PL_origenviron) {
1133 if ((PL_origenviron[0] == s + 1
1134#ifdef OS2
1135 || (PL_origenviron[0] == s + 9 && (s += 8))
1136#endif
1137 )
1138 ||
1139 (aligned &&
1140 (PL_origenviron[0] > s &&
1141 PL_origenviron[0] <=
1142 INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)))
1143 )
1144 {
1145#ifndef OS2
1146 s = PL_origenviron[0];
1147 while (*s) s++;
1148#endif
1149 my_setenv("NoNe SuCh", Nullch);
1150 /* Force copy of environment. */
1151 for (i = 1; PL_origenviron[i]; i++) {
1152 if (PL_origenviron[i] == s + 1
1153 ||
1154 (aligned &&
1155 (PL_origenviron[i] > s &&
1156 PL_origenviron[i] <=
1157 INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)))
1158 )
1159 {
1160 s = PL_origenviron[i];
1161 while (*s) s++;
1162 }
1163 else
1164 break;
54bfe034 1165 }
43c32782 1166 }
54bfe034 1167 }
284e1220 1168 PL_origalen = s - PL_origargv[0] + 1;
54bfe034
JH		 1169 }
1170
3280af22 1171 if (PL_do_undump) {
a0d0e21e
LW		 1172
1173 /* Come here if running an undumped a.out. */
1174
3280af22
NIS		 1175 PL_origfilename = savepv(argv[0]);
1176 PL_do_undump = FALSE;
a0d0e21e 1177 cxstack_ix = -1; /* start label stack again */
748a9306 1178 init_ids();
b7975bdd
NC		 1179 assert (!PL_tainted);
1180 TAINT;
1181 S_set_caret_X(aTHX);
1182 TAINT_NOT;
a0d0e21e
LW		 1183 init_postdump_symbols(argc,argv,env);
1184 return 0;
1185 }
1186
3280af22 1187 if (PL_main_root) {
3280af22
NIS		 1188 op_free(PL_main_root);
1189 PL_main_root = Nullop;
ff0cee69 1190 }
3280af22
NIS		 1191 PL_main_start = Nullop;
1192 SvREFCNT_dec(PL_main_cv);
1193 PL_main_cv = Nullcv;
79072805 1194
3280af22
NIS		 1195 time(&PL_basetime);
1196 oldscope = PL_scopestack_ix;
599cee73 1197 PL_dowarn = G_WARN_OFF;
f86702cc 1198
14dd3ad8 1199 JMPENV_PUSH(ret);
6224f72b 1200 switch (ret) {
312caa8e 1201 case 0:
14dd3ad8 1202 parse_body(env,xsinit);
7d30b5c4
GS		 1203 if (PL_checkav)
1204 call_list(oldscope, PL_checkav);
14dd3ad8
GS		 1205 ret = 0;
1206 break;
6224f72b
GS		 1207 case 1:
1208 STATUS_ALL_FAILURE;
1209 /* FALL THROUGH */
1210 case 2:
1211 /* my_exit() was called */
3280af22 1212 while (PL_scopestack_ix > oldscope)
6224f72b
GS		 1213 LEAVE;
1214 FREETMPS;
3280af22 1215 PL_curstash = PL_defstash;
7d30b5c4
GS		 1216 if (PL_checkav)
1217 call_list(oldscope, PL_checkav);
14dd3ad8
GS		 1218 ret = STATUS_NATIVE_EXPORT;
1219 break;
6224f72b 1220 case 3:
bf49b057 1221 PerlIO_printf(Perl_error_log, "panic: top_env\n");
14dd3ad8
GS		 1222 ret = 1;
1223 break;
6224f72b 1224 }
14dd3ad8
GS		 1225 JMPENV_POP;
1226 return ret;
1227}
1228
312caa8e 1229STATIC void *
14dd3ad8 1230S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
312caa8e 1231{
312caa8e 1232 int argc = PL_origargc;
8f42b153 1233 char **argv = PL_origargv;
e1ec3a88 1234 const char *scriptname = NULL;
312caa8e 1235 VOL bool dosearch = FALSE;
e1ec3a88 1236 const char *validarg = "";
312caa8e
CS		 1237 register SV *sv;
1238 register char *s;
e1ec3a88 1239 const char *cddir = Nullch;
20ef40cf 1240 bool minus_f = FALSE;
312caa8e 1241
ae3f3efd
PS		 1242 PL_fdscript = -1;
1243 PL_suidscript = -1;
3280af22 1244 sv_setpvn(PL_linestr,"",0);
79cb57f6 1245 sv = newSVpvn("",0); /* first used for -I flags */
6224f72b
GS		 1246 SAVEFREESV(sv);
1247 init_main_stash();
54310121 1248
6224f72b
GS		 1249 for (argc--,argv++; argc > 0; argc--,argv++) {
1250 if (argv[0][0] != '-' || !argv[0][1])
1251 break;
1252#ifdef DOSUID
1253 if (*validarg)
1254 validarg = " PHOOEY ";
1255 else
1256 validarg = argv[0];
ae3f3efd
PS		 1257 /*
1258 * Can we rely on the kernel to start scripts with argv[1] set to
1259 * contain all #! line switches (the whole line)? (argv[0] is set to
1260 * the interpreter name, argv[2] to the script name; argv[3] and
1261 * above may contain other arguments.)
1262 */
13281fa4 1263#endif
6224f72b
GS		 1264 s = argv[0]+1;
1265 reswitch:
1266 switch (*s) {
729a02f2 1267 case 'C':
1d5472a9
GS		 1268#ifndef PERL_STRICT_CR
1269 case '\r':
1270#endif
6224f72b
GS		 1271 case ' ':
1272 case '0':
1273 case 'F':
1274 case 'a':
1275 case 'c':
1276 case 'd':
1277 case 'D':
1278 case 'h':
1279 case 'i':
1280 case 'l':
1281 case 'M':
1282 case 'm':
1283 case 'n':
1284 case 'p':
1285 case 's':
1286 case 'u':
1287 case 'U':
1288 case 'v':
599cee73
PM		 1289 case 'W':
1290 case 'X':
6224f72b 1291 case 'w':
06492da6 1292 case 'A':
155aba94 1293 if ((s = moreswitches(s)))
6224f72b
GS		 1294 goto reswitch;
1295 break;
33b78306 1296
1dbad523 1297 case 't':
22f7c9c9 1298 CHECK_MALLOC_TOO_LATE_FOR('t');
317ea90d
MS		 1299 if( !PL_tainting ) {
1300 PL_taint_warn = TRUE;
1301 PL_tainting = TRUE;
1302 }
1303 s++;
1304 goto reswitch;
6224f72b 1305 case 'T':
22f7c9c9 1306 CHECK_MALLOC_TOO_LATE_FOR('T');
3280af22 1307 PL_tainting = TRUE;
317ea90d 1308 PL_taint_warn = FALSE;
6224f72b
GS		 1309 s++;
1310 goto reswitch;
f86702cc 1311
6224f72b 1312 case 'e':
bf4acbe4
GS		 1313#ifdef MACOS_TRADITIONAL
1314 /* ignore -e for Dev:Pseudo argument */
1315 if (argv[1] && !strcmp(argv[1], "Dev:Pseudo"))
e55ac0fa 1316 break;
bf4acbe4 1317#endif
ae3f3efd 1318 forbid_setid("-e");
3280af22 1319 if (!PL_e_script) {
79cb57f6 1320 PL_e_script = newSVpvn("",0);
0cb96387 1321 filter_add(read_e_script, NULL);
6224f72b
GS		 1322 }
1323 if (*++s)
3280af22 1324 sv_catpv(PL_e_script, s);
6224f72b 1325 else if (argv[1]) {
3280af22 1326 sv_catpv(PL_e_script, argv[1]);
6224f72b
GS		 1327 argc--,argv++;
1328 }
1329 else
cea2e8a9 1330 Perl_croak(aTHX_ "No code specified for -e");
3280af22 1331 sv_catpv(PL_e_script, "\n");
6224f72b 1332 break;
afe37c7d 1333
20ef40cf
GA		 1334 case 'f':
1335 minus_f = TRUE;
1336 s++;
1337 goto reswitch;
1338
6224f72b
GS		 1339 case 'I': /* -I handled both here and in moreswitches() */
1340 forbid_setid("-I");
1341 if (!*++s && (s=argv[1]) != Nullch) {
1342 argc--,argv++;
1343 }
6224f72b 1344 if (s && *s) {
0df16ed7
GS		 1345 char *p;
1346 STRLEN len = strlen(s);
1347 p = savepvn(s, len);
88fe16b2 1348 incpush(p, TRUE, TRUE, FALSE, FALSE);
0df16ed7
GS		 1349 sv_catpvn(sv, "-I", 2);
1350 sv_catpvn(sv, p, len);
1351 sv_catpvn(sv, " ", 1);
6224f72b 1352 Safefree(p);
0df16ed7
GS		 1353 }
1354 else
a67e862a 1355 Perl_croak(aTHX_ "No directory specified for -I");
6224f72b
GS		 1356 break;
1357 case 'P':
1358 forbid_setid("-P");
3280af22 1359 PL_preprocess = TRUE;
6224f72b
GS		 1360 s++;
1361 goto reswitch;
1362 case 'S':
1363 forbid_setid("-S");
1364 dosearch = TRUE;
1365 s++;
1366 goto reswitch;
1367 case 'V':
3280af22
NIS		 1368 if (!PL_preambleav)
1369 PL_preambleav = newAV();
1370 av_push(PL_preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
6224f72b 1371 if (*++s != ':') {
efcaa95b
YST		 1372 STRLEN opts;
1373
3280af22 1374 PL_Sv = newSVpv("print myconfig();",0);
6224f72b 1375#ifdef VMS
6b88bc9c 1376 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
6224f72b 1377#else
3280af22 1378 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
6224f72b 1379#endif
efcaa95b
YST		 1380 opts = SvCUR(PL_Sv);
1381
3280af22 1382 sv_catpv(PL_Sv,"\" Compile-time options:");
6224f72b 1383# ifdef DEBUGGING
3280af22 1384 sv_catpv(PL_Sv," DEBUGGING");
6224f72b 1385# endif
6224f72b 1386# ifdef MULTIPLICITY
8f872242 1387 sv_catpv(PL_Sv," MULTIPLICITY");
6224f72b 1388# endif
4d1ff10f
AB		 1389# ifdef USE_5005THREADS
1390 sv_catpv(PL_Sv," USE_5005THREADS");
b363f7ed 1391# endif
ac5e8965
JH		 1392# ifdef USE_ITHREADS
1393 sv_catpv(PL_Sv," USE_ITHREADS");
1394# endif
10cc9d2a
JH		 1395# ifdef USE_64_BIT_INT
1396 sv_catpv(PL_Sv," USE_64_BIT_INT");
1397# endif
1398# ifdef USE_64_BIT_ALL
1399 sv_catpv(PL_Sv," USE_64_BIT_ALL");
ac5e8965
JH		 1400# endif
1401# ifdef USE_LONG_DOUBLE
1402 sv_catpv(PL_Sv," USE_LONG_DOUBLE");
1403# endif
53430762
JH		 1404# ifdef USE_LARGE_FILES
1405 sv_catpv(PL_Sv," USE_LARGE_FILES");
1406# endif
ac5e8965
JH		 1407# ifdef USE_SOCKS
1408 sv_catpv(PL_Sv," USE_SOCKS");
1409# endif
20ef40cf
GA		 1410# ifdef USE_SITECUSTOMIZE
1411 sv_catpv(PL_Sv," USE_SITECUSTOMIZE");
1412# endif
b363f7ed
GS		 1413# ifdef PERL_IMPLICIT_CONTEXT
1414 sv_catpv(PL_Sv," PERL_IMPLICIT_CONTEXT");
1415# endif
1416# ifdef PERL_IMPLICIT_SYS
1417 sv_catpv(PL_Sv," PERL_IMPLICIT_SYS");
1418# endif
efcaa95b
YST		 1419
1420 while (SvCUR(PL_Sv) > opts+76) {
1421 /* find last space after "options: " and before col 76 */
1422
dd374669
AL		 1423 const char *space;
1424 char *pv = SvPV_nolen(PL_Sv);
1425 const char c = pv[opts+76];
efcaa95b
YST		 1426 pv[opts+76] = '\0';
1427 space = strrchr(pv+opts+26, ' ');
1428 pv[opts+76] = c;
1429 if (!space) break; /* "Can't happen" */
1430
1431 /* break the line before that space */
1432
1433 opts = space - pv;
1434 sv_insert(PL_Sv, opts, 0,
1435 "\\n ", 25);
1436 }
1437
3280af22 1438 sv_catpv(PL_Sv,"\\n\",");
b363f7ed 1439
6224f72b
GS		 1440#if defined(LOCAL_PATCH_COUNT)
1441 if (LOCAL_PATCH_COUNT > 0) {
1442 int i;
3280af22 1443 sv_catpv(PL_Sv,"\" Locally applied patches:\\n\",");
6224f72b 1444 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
3280af22 1445 if (PL_localpatches[i])
acb03d05
AB		 1446 Perl_sv_catpvf(aTHX_ PL_Sv,"q%c\t%s\n%c,",
1447 0, PL_localpatches[i], 0);
6224f72b
GS		 1448 }
1449 }
1450#endif
cea2e8a9 1451 Perl_sv_catpvf(aTHX_ PL_Sv,"\" Built under %s\\n\"",OSNAME);
6224f72b
GS		 1452#ifdef __DATE__
1453# ifdef __TIME__
cea2e8a9 1454 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
6224f72b 1455# else
cea2e8a9 1456 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled on %s\\n\"",__DATE__);
6224f72b
GS		 1457# endif
1458#endif
3280af22 1459 sv_catpv(PL_Sv, "; \
6224f72b 1460$\"=\"\\n \"; \
69fcd688
JH		 1461@env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; ");
1462#ifdef __CYGWIN__
1463 sv_catpv(PL_Sv,"\
1464push @env, \"CYGWIN=\\\"$ENV{CYGWIN}\\\"\";");
1465#endif
1466 sv_catpv(PL_Sv, "\
6224f72b
GS		 1467print \" \\%ENV:\\n @env\\n\" if @env; \
1468print \" \\@INC:\\n @INC\\n\";");
1469 }
1470 else {
3280af22
NIS		 1471 PL_Sv = newSVpv("config_vars(qw(",0);
1472 sv_catpv(PL_Sv, ++s);
1473 sv_catpv(PL_Sv, "))");
6224f72b
GS		 1474 s += strlen(s);
1475 }
3280af22 1476 av_push(PL_preambleav, PL_Sv);
6224f72b
GS		 1477 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
1478 goto reswitch;
1479 case 'x':
3280af22 1480 PL_doextract = TRUE;
6224f72b
GS		 1481 s++;
1482 if (*s)
f4c556ac 1483 cddir = s;
6224f72b
GS		 1484 break;
1485 case 0:
1486 break;
1487 case '-':
1488 if (!*++s || isSPACE(*s)) {
1489 argc--,argv++;
1490 goto switch_end;
1491 }
1492 /* catch use of gnu style long options */
1493 if (strEQ(s, "version")) {
dd374669 1494 s = (char *)"v";
6224f72b
GS		 1495 goto reswitch;
1496 }
1497 if (strEQ(s, "help")) {
dd374669 1498 s = (char *)"h";
6224f72b
GS		 1499 goto reswitch;
1500 }
1501 s--;
1502 /* FALL THROUGH */
1503 default:
cea2e8a9 1504 Perl_croak(aTHX_ "Unrecognized switch: -%s (-h will show valid options)",s);
8d063cd8
LW		 1505 }
1506 }
6224f72b 1507 switch_end:
54310121 1508
f675dbe5
CB		 1509 if (
1510#ifndef SECURE_INTERNAL_GETENV
1511 !PL_tainting &&
1512#endif
cf756827 1513 (s = PerlEnv_getenv("PERL5OPT")))
0df16ed7 1514 {
e1ec3a88 1515 const char *popt = s;
74288ac8
GS		 1516 while (isSPACE(*s))
1517 s++;
317ea90d 1518 if (*s == '-' && *(s+1) == 'T') {
22f7c9c9 1519 CHECK_MALLOC_TOO_LATE_FOR('T');
74288ac8 1520 PL_tainting = TRUE;
317ea90d
MS		 1521 PL_taint_warn = FALSE;
1522 }
74288ac8 1523 else {
cf756827 1524 char *popt_copy = Nullch;
74288ac8 1525 while (s && *s) {
4ea8f8fb 1526 char *d;
74288ac8
GS		 1527 while (isSPACE(*s))
1528 s++;
1529 if (*s == '-') {
1530 s++;
1531 if (isSPACE(*s))
1532 continue;
1533 }
4ea8f8fb 1534 d = s;
74288ac8
GS		 1535 if (!*s)
1536 break;
06492da6 1537 if (!strchr("DIMUdmtwA", *s))
cea2e8a9 1538 Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s);
4ea8f8fb
MS		 1539 while (++s && *s) {
1540 if (isSPACE(*s)) {
cf756827
GS		 1541 if (!popt_copy) {
1542 popt_copy = SvPVX(sv_2mortal(newSVpv(popt,0)));
1543 s = popt_copy + (s - popt);
1544 d = popt_copy + (d - popt);
1545 }
4ea8f8fb
MS		 1546 *s++ = '\0';
1547 break;
1548 }
1549 }
1c4db469 1550 if (*d == 't') {
317ea90d
MS		 1551 if( !PL_tainting ) {
1552 PL_taint_warn = TRUE;
1553 PL_tainting = TRUE;
1554 }
1c4db469
RGS		 1555 } else {
1556 moreswitches(d);
1557 }
6224f72b 1558 }
6224f72b
GS		 1559 }
1560 }
a0d0e21e 1561
20ef40cf
GA		 1562#ifdef USE_SITECUSTOMIZE
1563 if (!minus_f) {
1564 if (!PL_preambleav)
1565 PL_preambleav = newAV();
1566 av_unshift(PL_preambleav, 1);
1567 (void)av_store(PL_preambleav, 0, Perl_newSVpvf(aTHX_ "BEGIN { do '%s/sitecustomize.pl' }", SITELIB_EXP));
1568 }
1569#endif
1570
317ea90d
MS		 1571 if (PL_taint_warn && PL_dowarn != G_WARN_ALL_OFF) {
1572 PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
1573 }
1574
6224f72b
GS		 1575 if (!scriptname)
1576 scriptname = argv[0];
3280af22 1577 if (PL_e_script) {
6224f72b
GS		 1578 argc++,argv--;
1579 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
1580 }
1581 else if (scriptname == Nullch) {
1582#ifdef MSDOS
1583 if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
1584 moreswitches("h");
1585#endif
1586 scriptname = "-";
1587 }
1588
b7975bdd
NC		 1589 /* Set $^X early so that it can be used for relocatable paths in @INC */
1590 assert (!PL_tainted);
1591 TAINT;
1592 S_set_caret_X(aTHX);
1593 TAINT_NOT;
6224f72b
GS		 1594 init_perllib();
1595
c5cccb17 1596 open_script(scriptname,dosearch,sv);
6224f72b 1597
c5cccb17 1598 validate_suid(validarg, scriptname);
6224f72b 1599
64ca3a65 1600#ifndef PERL_MICRO
0b5b802d
GS		 1601#if defined(SIGCHLD) || defined(SIGCLD)
1602 {
1603#ifndef SIGCHLD
1604# define SIGCHLD SIGCLD
1605#endif
1606 Sighandler_t sigstate = rsignal_state(SIGCHLD);
1607 if (sigstate == SIG_IGN) {
1608 if (ckWARN(WARN_SIGNAL))
9014280d 1609 Perl_warner(aTHX_ packWARN(WARN_SIGNAL),
0b5b802d
GS		 1610 "Can't ignore signal CHLD, forcing to default");
1611 (void)rsignal(SIGCHLD, (Sighandler_t)SIG_DFL);
1612 }
1613 }
1614#endif
64ca3a65 1615#endif
0b5b802d 1616
bf4acbe4
GS		 1617#ifdef MACOS_TRADITIONAL
1618 if (PL_doextract || gMacPerl_AlwaysExtract) {
1619#else
f4c556ac 1620 if (PL_doextract) {
bf4acbe4 1621#endif
6224f72b 1622 find_beginning();
dd374669 1623 if (cddir && PerlDir_chdir( (char *)cddir ) < 0)
f4c556ac
GS		 1624 Perl_croak(aTHX_ "Can't chdir to %s",cddir);
1625
1626 }
6224f72b 1627
3280af22
NIS		 1628 PL_main_cv = PL_compcv = (CV*)NEWSV(1104,0);
1629 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
1630 CvUNIQUE_on(PL_compcv);
1631
dd2155a4 1632 CvPADLIST(PL_compcv) = pad_new(0);
4d1ff10f 1633#ifdef USE_5005THREADS
533c011a
NIS		 1634 CvOWNER(PL_compcv) = 0;
1635 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
1636 MUTEX_INIT(CvMUTEXP(PL_compcv));
4d1ff10f 1637#endif /* USE_5005THREADS */
6224f72b 1638
0c4f7ff0 1639 boot_core_PerlIO();
6224f72b 1640 boot_core_UNIVERSAL();
09bef843 1641 boot_core_xsutils();
6224f72b
GS		 1642
1643 if (xsinit)
acfe0abc 1644 (*xsinit)(aTHX); /* in case linked C routines want magical variables */
64ca3a65 1645#ifndef PERL_MICRO
ed79a026 1646#if defined(VMS) || defined(WIN32) || defined(DJGPP) || defined(__CYGWIN__) || defined(EPOC)
c5be433b 1647 init_os_extras();
6224f72b 1648#endif
64ca3a65 1649#endif
6224f72b 1650
29209bc5 1651#ifdef USE_SOCKS
1b9c9cf5
DH		 1652# ifdef HAS_SOCKS5_INIT
1653 socks5_init(argv[0]);
1654# else
29209bc5 1655 SOCKSinit(argv[0]);
1b9c9cf5 1656# endif
ac27b0f5 1657#endif
29209bc5 1658
6224f72b
GS		 1659 init_predump_symbols();
1660 /* init_postdump_symbols not currently designed to be called */
1661 /* more than once (ENV isn't cleared first, for example) */
1662 /* But running with -u leaves %ENV & @ARGV undefined! XXX */
3280af22 1663 if (!PL_do_undump)
6224f72b
GS		 1664 init_postdump_symbols(argc,argv,env);
1665
a05d7ebb
JH		 1666 /* PL_unicode is turned on by -C or by $ENV{PERL_UNICODE}.
1667 * PL_utf8locale is conditionally turned on by
085a54d9 1668 * locale.c:Perl_init_i18nl10n() if the environment
a05d7ebb 1669 * look like the user wants to use UTF-8. */
06e66572
JH		 1670 if (PL_unicode) {
1671 /* Requires init_predump_symbols(). */
a05d7ebb 1672 if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) {
06e66572
JH		 1673 IO* io;
1674 PerlIO* fp;
1675 SV* sv;
1676
a05d7ebb 1677 /* Turn on UTF-8-ness on STDIN, STDOUT, STDERR
06e66572 1678 * and the default open disciplines. */
a05d7ebb
JH		 1679 if ((PL_unicode & PERL_UNICODE_STDIN_FLAG) &&
1680 PL_stdingv && (io = GvIO(PL_stdingv)) &&
1681 (fp = IoIFP(io)))
1682 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
1683 if ((PL_unicode & PERL_UNICODE_STDOUT_FLAG) &&
1684 PL_defoutgv && (io = GvIO(PL_defoutgv)) &&
1685 (fp = IoOFP(io)))
1686 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
1687 if ((PL_unicode & PERL_UNICODE_STDERR_FLAG) &&
1688 PL_stderrgv && (io = GvIO(PL_stderrgv)) &&
1689 (fp = IoOFP(io)))
1690 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
1691 if ((PL_unicode & PERL_UNICODE_INOUT_FLAG) &&
1692 (sv = GvSV(gv_fetchpv("\017PEN", TRUE, SVt_PV)))) {
1693 U32 in = PL_unicode & PERL_UNICODE_IN_FLAG;
1694 U32 out = PL_unicode & PERL_UNICODE_OUT_FLAG;
1695 if (in) {
1696 if (out)
1697 sv_setpvn(sv, ":utf8\0:utf8", 11);
1698 else
1699 sv_setpvn(sv, ":utf8\0", 6);
1700 }
1701 else if (out)
1702 sv_setpvn(sv, "\0:utf8", 6);
1703 SvSETMAGIC(sv);
1704 }
b310b053
JH		 1705 }
1706 }
1707
4ffa73a3
JH		 1708 if ((s = PerlEnv_getenv("PERL_SIGNALS"))) {
1709 if (strEQ(s, "unsafe"))
1710 PL_signals |= PERL_SIGNALS_UNSAFE_FLAG;
1711 else if (strEQ(s, "safe"))
1712 PL_signals &= ~PERL_SIGNALS_UNSAFE_FLAG;
1713 else
1714 Perl_croak(aTHX_ "PERL_SIGNALS illegal: \"%s\"", s);
1715 }
1716
6224f72b
GS		 1717 init_lexer();
1718
1719 /* now parse the script */
1720
93189314 1721 SETERRNO(0,SS_NORMAL);
3280af22 1722 PL_error_count = 0;
bf4acbe4
GS		 1723#ifdef MACOS_TRADITIONAL
1724 if (gMacPerl_SyntaxError = (yyparse() || PL_error_count)) {
1725 if (PL_minus_c)
1726 Perl_croak(aTHX_ "%s had compilation errors.\n", MacPerl_MPWFileName(PL_origfilename));
1727 else {
1728 Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
1729 MacPerl_MPWFileName(PL_origfilename));
1730 }
1731 }
1732#else
3280af22
NIS		 1733 if (yyparse() || PL_error_count) {
1734 if (PL_minus_c)
cea2e8a9 1735 Perl_croak(aTHX_ "%s had compilation errors.\n", PL_origfilename);
6224f72b 1736 else {
cea2e8a9 1737 Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
097ee67d 1738 PL_origfilename);
6224f72b
GS		 1739 }
1740 }
bf4acbe4 1741#endif
57843af0 1742 CopLINE_set(PL_curcop, 0);
3280af22
NIS		 1743 PL_curstash = PL_defstash;
1744 PL_preprocess = FALSE;
1745 if (PL_e_script) {
1746 SvREFCNT_dec(PL_e_script);
1747 PL_e_script = Nullsv;
6224f72b
GS		 1748 }
1749
3280af22 1750 if (PL_do_undump)
6224f72b
GS		 1751 my_unexec();
1752
57843af0
GS		 1753 if (isWARN_ONCE) {
1754 SAVECOPFILE(PL_curcop);
1755 SAVECOPLINE(PL_curcop);
3280af22 1756 gv_check(PL_defstash);
57843af0 1757 }
6224f72b
GS		 1758
1759 LEAVE;
1760 FREETMPS;
1761
1762#ifdef MYMALLOC
1763 if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
1764 dump_mstats("after compilation:");
1765#endif
1766
1767 ENTER;
3280af22 1768 PL_restartop = 0;
312caa8e 1769 return NULL;
6224f72b
GS		 1770}
1771
954c1994
GS		 1772/*
1773=for apidoc perl_run
1774
1775Tells a Perl interpreter to run. See L<perlembed>.
1776
1777=cut
1778*/
1779
6224f72b 1780int
0cb96387 1781perl_run(pTHXx)
6224f72b 1782{
6224f72b 1783 I32 oldscope;
14dd3ad8 1784 int ret = 0;
db36c5a1 1785 dJMPENV;
6224f72b 1786
3280af22 1787 oldscope = PL_scopestack_ix;
96e176bf
CL		 1788#ifdef VMS
1789 VMSISH_HUSHED = 0;
1790#endif
6224f72b 1791
14dd3ad8 1792 JMPENV_PUSH(ret);
6224f72b
GS		 1793 switch (ret) {
1794 case 1:
1795 cxstack_ix = -1; /* start context stack again */
312caa8e 1796 goto redo_body;
14dd3ad8 1797 case 0: /* normal completion */
14dd3ad8
GS		 1798 redo_body:
1799 run_body(oldscope);
14dd3ad8
GS		 1800 /* FALL THROUGH */
1801 case 2: /* my_exit() */
3280af22 1802 while (PL_scopestack_ix > oldscope)
6224f72b
GS		 1803 LEAVE;
1804 FREETMPS;
3280af22 1805 PL_curstash = PL_defstash;
3a1ee7e8 1806 if (!(PL_exit_flags & PERL_EXIT_DESTRUCT_END) &&
31d77e54
AB		 1807 PL_endav && !PL_minus_c)
1808 call_list(oldscope, PL_endav);
6224f72b
GS		 1809#ifdef MYMALLOC
1810 if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
1811 dump_mstats("after execution: ");
1812#endif
14dd3ad8
GS		 1813 ret = STATUS_NATIVE_EXPORT;
1814 break;
6224f72b 1815 case 3:
312caa8e
CS		 1816 if (PL_restartop) {
1817 POPSTACK_TO(PL_mainstack);
1818 goto redo_body;
6224f72b 1819 }
bf49b057 1820 PerlIO_printf(Perl_error_log, "panic: restartop\n");
312caa8e 1821 FREETMPS;
14dd3ad8
GS		 1822 ret = 1;
1823 break;
6224f72b
GS		 1824 }
1825
14dd3ad8
GS		 1826 JMPENV_POP;
1827 return ret;
312caa8e
CS		 1828}
1829
14dd3ad8 1830
dd374669 1831STATIC void
14dd3ad8
GS		 1832S_run_body(pTHX_ I32 oldscope)
1833{
6224f72b 1834 DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
3280af22 1835 PL_sawampersand ? "Enabling" : "Omitting"));
6224f72b 1836
3280af22 1837 if (!PL_restartop) {
6224f72b 1838 DEBUG_x(dump_all());
ecae49c0
NC		 1839 if (!DEBUG_q_TEST)
1840 PERL_DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
b900a521
JH		 1841 DEBUG_S(PerlIO_printf(Perl_debug_log, "main thread is 0x%"UVxf"\n",
1842 PTR2UV(thr)));
6224f72b 1843
3280af22 1844 if (PL_minus_c) {
bf4acbe4 1845#ifdef MACOS_TRADITIONAL
e69a2255
JH		 1846 PerlIO_printf(Perl_error_log, "%s%s syntax OK\n",
1847 (gMacPerl_ErrorFormat ? "# " : ""),
1848 MacPerl_MPWFileName(PL_origfilename));
bf4acbe4 1849#else
bf49b057 1850 PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename);
bf4acbe4 1851#endif
6224f72b
GS		 1852 my_exit(0);
1853 }
3280af22 1854 if (PERLDB_SINGLE && PL_DBsingle)
ac27b0f5 1855 sv_setiv(PL_DBsingle, 1);
3280af22
NIS		 1856 if (PL_initav)
1857 call_list(oldscope, PL_initav);
6224f72b
GS		 1858 }
1859
1860 /* do it */
1861
3280af22 1862 if (PL_restartop) {
533c011a 1863 PL_op = PL_restartop;
3280af22 1864 PL_restartop = 0;
cea2e8a9 1865 CALLRUNOPS(aTHX);
6224f72b 1866 }
3280af22
NIS		 1867 else if (PL_main_start) {
1868 CvDEPTH(PL_main_cv) = 1;
533c011a 1869 PL_op = PL_main_start;
cea2e8a9 1870 CALLRUNOPS(aTHX);
6224f72b
GS		 1871 }
1872
f6b3007c
JH		 1873 my_exit(0);
1874 /* NOTREACHED */
6224f72b
GS		 1875}
1876
954c1994 1877/*
ccfc67b7
JH		 1878=head1 SV Manipulation Functions
1879
954c1994
GS		 1880=for apidoc p||get_sv
1881
1882Returns the SV of the specified Perl scalar. If C<create> is set and the
1883Perl variable does not exist then it will be created. If C<create> is not
1884set and the variable does not exist then NULL is returned.
1885
1886=cut
1887*/
1888
6224f72b 1889SV*
864dbfa3 1890Perl_get_sv(pTHX_ const char *name, I32 create)
6224f72b
GS		 1891{
1892 GV *gv;
4d1ff10f 1893#ifdef USE_5005THREADS
6224f72b
GS		 1894 if (name[1] == '\0' && !isALPHA(name[0])) {
1895 PADOFFSET tmp = find_threadsv(name);
411caa50 1896 if (tmp != NOT_IN_PAD)
6224f72b 1897 return THREADSV(tmp);
6224f72b 1898 }
4d1ff10f 1899#endif /* USE_5005THREADS */
6224f72b
GS		 1900 gv = gv_fetchpv(name, create, SVt_PV);
1901 if (gv)
1902 return GvSV(gv);
1903 return Nullsv;
1904}
1905
954c1994 1906/*
ccfc67b7
JH		 1907=head1 Array Manipulation Functions
1908
954c1994
GS		 1909=for apidoc p||get_av
1910
1911Returns the AV of the specified Perl array. If C<create> is set and the
1912Perl variable does not exist then it will be created. If C<create> is not
1913set and the variable does not exist then NULL is returned.
1914
1915=cut
1916*/
1917
6224f72b 1918AV*
864dbfa3 1919Perl_get_av(pTHX_ const char *name, I32 create)
6224f72b
GS		 1920{
1921 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
1922 if (create)
1923 return GvAVn(gv);
1924 if (gv)
1925 return GvAV(gv);
1926 return Nullav;
1927}
1928
954c1994 1929/*
ccfc67b7
JH		 1930=head1 Hash Manipulation Functions
1931
954c1994
GS		 1932=for apidoc p||get_hv
1933
1934Returns the HV of the specified Perl hash. If C<create> is set and the
1935Perl variable does not exist then it will be created. If C<create> is not
1936set and the variable does not exist then NULL is returned.
1937
1938=cut
1939*/
1940
6224f72b 1941HV*
864dbfa3 1942Perl_get_hv(pTHX_ const char *name, I32 create)
6224f72b 1943{
a0d0e21e
LW		 1944 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
1945 if (create)
1946 return GvHVn(gv);
1947 if (gv)
1948 return GvHV(gv);
1949 return Nullhv;
1950}
1951
954c1994 1952/*
ccfc67b7
JH		 1953=head1 CV Manipulation Functions
1954
954c1994
GS		 1955=for apidoc p||get_cv
1956
1957Returns the CV of the specified Perl subroutine. If C<create> is set and
1958the Perl subroutine does not exist then it will be declared (which has the
1959same effect as saying C<sub name;>). If C<create> is not set and the
1960subroutine does not exist then NULL is returned.
1961
1962=cut
1963*/
1964
a0d0e21e 1965CV*
864dbfa3 1966Perl_get_cv(pTHX_ const char *name, I32 create)
a0d0e21e
LW		 1967{
1968 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
b099ddc0 1969 /* XXX unsafe for threads if eval_owner isn't held */
f6ec51f7
GS		 1970 /* XXX this is probably not what they think they're getting.
1971 * It has the same effect as "sub name;", i.e. just a forward
1972 * declaration! */
8ebc5c01 1973 if (create && !GvCVu(gv))
774d564b 1974 return newSUB(start_subparse(FALSE, 0),
a0d0e21e 1975 newSVOP(OP_CONST, 0, newSVpv(name,0)),
4633a7c4 1976 Nullop,
a0d0e21e
LW		 1977 Nullop);
1978 if (gv)
8ebc5c01 1979 return GvCVu(gv);
a0d0e21e
LW		 1980 return Nullcv;
1981}
1982
79072805
LW		 1983/* Be sure to refetch the stack pointer after calling these routines. */
1984
954c1994 1985/*
ccfc67b7
JH		 1986
1987=head1 Callback Functions
1988
954c1994
GS		 1989=for apidoc p||call_argv
1990
1991Performs a callback to the specified Perl sub. See L<perlcall>.
1992
1993=cut
1994*/
1995
a0d0e21e 1996I32
8f42b153 1997Perl_call_argv(pTHX_ const char *sub_name, I32 flags, register char **argv)
ac27b0f5 1998
8ac85365
NIS		 1999 /* See G_* flags in cop.h */
2000 /* null terminated arg list */
8990e307 2001{
a0d0e21e 2002 dSP;
8990e307 2003
924508f0 2004 PUSHMARK(SP);
a0d0e21e 2005 if (argv) {
8990e307 2006 while (*argv) {
a0d0e21e 2007 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
8990e307
LW		 2008 argv++;
2009 }
a0d0e21e 2010 PUTBACK;
8990e307 2011 }
864dbfa3 2012 return call_pv(sub_name, flags);
8990e307
LW		 2013}
2014
954c1994
GS		 2015/*
2016=for apidoc p||call_pv
2017
2018Performs a callback to the specified Perl sub. See L<perlcall>.
2019
2020=cut
2021*/
2022
a0d0e21e 2023I32
864dbfa3 2024Perl_call_pv(pTHX_ const char *sub_name, I32 flags)
8ac85365
NIS		 2025 /* name of the subroutine */
2026 /* See G_* flags in cop.h */
a0d0e21e 2027{
864dbfa3 2028 return call_sv((SV*)get_cv(sub_name, TRUE), flags);
a0d0e21e
LW		 2029}
2030
954c1994
GS		 2031/*
2032=for apidoc p||call_method
2033
2034Performs a callback to the specified Perl method. The blessed object must
2035be on the stack. See L<perlcall>.
2036
2037=cut
2038*/
2039
a0d0e21e 2040I32
864dbfa3 2041Perl_call_method(pTHX_ const char *methname, I32 flags)
8ac85365
NIS		 2042 /* name of the subroutine */
2043 /* See G_* flags in cop.h */
a0d0e21e 2044{
968b3946 2045 return call_sv(sv_2mortal(newSVpv(methname,0)), flags | G_METHOD);
a0d0e21e
LW		 2046}
2047
2048/* May be called with any of a CV, a GV, or an SV containing the name. */
954c1994
GS		 2049/*
2050=for apidoc p||call_sv
2051
2052Performs a callback to the Perl sub whose name is in the SV. See
2053L<perlcall>.
2054
2055=cut
2056*/
2057
a0d0e21e 2058I32
864dbfa3 2059Perl_call_sv(pTHX_ SV *sv, I32 flags)
8ac85365 2060 /* See G_* flags in cop.h */
a0d0e21e 2061{
924508f0 2062 dSP;
a0d0e21e 2063 LOGOP myop; /* fake syntax tree node */
968b3946 2064 UNOP method_op;
aa689395 2065 I32 oldmark;
13689cfe 2066 volatile I32 retval = 0;
a0d0e21e 2067 I32 oldscope;
54310121 2068 bool oldcatch = CATCH_GET;
6224f72b 2069 int ret;
533c011a 2070 OP* oldop = PL_op;
db36c5a1 2071 dJMPENV;
1e422769 2072
a0d0e21e
LW		 2073 if (flags & G_DISCARD) {
2074 ENTER;
2075 SAVETMPS;
2076 }
2077
aa689395 2078 Zero(&myop, 1, LOGOP);
54310121 2079 myop.op_next = Nullop;
f51d4af5 2080 if (!(flags & G_NOARGS))
aa689395 2081 myop.op_flags |= OPf_STACKED;
54310121 2082 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
2083 (flags & G_ARRAY) ? OPf_WANT_LIST :
2084 OPf_WANT_SCALAR);
462e5cf6 2085 SAVEOP();
533c011a 2086 PL_op = (OP*)&myop;
aa689395 2087
3280af22
NIS		 2088 EXTEND(PL_stack_sp, 1);
2089 *++PL_stack_sp = sv;
aa689395 2090 oldmark = TOPMARK;
3280af22 2091 oldscope = PL_scopestack_ix;
a0d0e21e 2092
3280af22 2093 if (PERLDB_SUB && PL_curstash != PL_debstash
36477c24 2094 /* Handle first BEGIN of -d. */
3280af22 2095 && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub)))
36477c24 2096 /* Try harder, since this may have been a sighandler, thus
2097 * curstash may be meaningless. */
3280af22 2098 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != PL_debstash)
491527d0 2099 && !(flags & G_NODEBUG))
533c011a 2100 PL_op->op_private |= OPpENTERSUB_DB;
a0d0e21e 2101
968b3946
GS		 2102 if (flags & G_METHOD) {
2103 Zero(&method_op, 1, UNOP);
2104 method_op.op_next = PL_op;
2105 method_op.op_ppaddr = PL_ppaddr[OP_METHOD];
2106 myop.op_ppaddr = PL_ppaddr[OP_ENTERSUB];
f39d0b86 2107 PL_op = (OP*)&method_op;
968b3946
GS		 2108 }
2109
312caa8e 2110 if (!(flags & G_EVAL)) {
0cdb2077 2111 CATCH_SET(TRUE);
14dd3ad8 2112 call_body((OP*)&myop, FALSE);
312caa8e 2113 retval = PL_stack_sp - (PL_stack_base + oldmark);
0253cb41 2114 CATCH_SET(oldcatch);
312caa8e
CS		 2115 }
2116 else {
d78bda3d 2117 myop.op_other = (OP*)&myop;
3280af22 2118 PL_markstack_ptr--;
4633a7c4
LW		 2119 /* we're trying to emulate pp_entertry() here */
2120 {
c09156bb 2121 register PERL_CONTEXT *cx;
54310121 2122 I32 gimme = GIMME_V;
ac27b0f5 2123
4633a7c4
LW		 2124 ENTER;
2125 SAVETMPS;
ac27b0f5 2126
1d76a5c3 2127 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
4633a7c4 2128 PUSHEVAL(cx, 0, 0);
533c011a 2129 PL_eval_root = PL_op; /* Only needed so that goto works right. */
ac27b0f5 2130
faef0170 2131 PL_in_eval = EVAL_INEVAL;
4633a7c4 2132 if (flags & G_KEEPERR)
faef0170 2133 PL_in_eval |= EVAL_KEEPERR;
4633a7c4 2134 else
38a03e6e 2135 sv_setpv(ERRSV,"");
4633a7c4 2136 }
3280af22 2137 PL_markstack_ptr++;
a0d0e21e 2138
14dd3ad8 2139 JMPENV_PUSH(ret);
6224f72b
GS		 2140 switch (ret) {
2141 case 0:
14dd3ad8
GS		 2142 redo_body:
2143 call_body((OP*)&myop, FALSE);
312caa8e
CS		 2144 retval = PL_stack_sp - (PL_stack_base + oldmark);
2145 if (!(flags & G_KEEPERR))
2146 sv_setpv(ERRSV,"");
a0d0e21e 2147 break;
6224f72b 2148 case 1:
f86702cc 2149 STATUS_ALL_FAILURE;
a0d0e21e 2150 /* FALL THROUGH */
6224f72b 2151 case 2:
a0d0e21e 2152 /* my_exit() was called */
3280af22 2153 PL_curstash = PL_defstash;
a0d0e21e 2154 FREETMPS;
14dd3ad8 2155 JMPENV_POP;
cc3604b1 2156 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
cea2e8a9 2157 Perl_croak(aTHX_ "Callback called exit");
f86702cc 2158 my_exit_jump();
a0d0e21e 2159 /* NOTREACHED */
6224f72b 2160 case 3:
3280af22 2161 if (PL_restartop) {
533c011a 2162 PL_op = PL_restartop;
3280af22 2163 PL_restartop = 0;
312caa8e 2164 goto redo_body;
a0d0e21e 2165 }
3280af22 2166 PL_stack_sp = PL_stack_base + oldmark;
a0d0e21e
LW		 2167 if (flags & G_ARRAY)
2168 retval = 0;
2169 else {
2170 retval = 1;
3280af22 2171 *++PL_stack_sp = &PL_sv_undef;
a0d0e21e 2172 }
312caa8e 2173 break;
a0d0e21e 2174 }
a0d0e21e 2175
3280af22 2176 if (PL_scopestack_ix > oldscope) {
a0a2876f
LW		 2177 SV **newsp;
2178 PMOP *newpm;
2179 I32 gimme;
c09156bb 2180 register PERL_CONTEXT *cx;
a0a2876f
LW		 2181 I32 optype;
2182
2183 POPBLOCK(cx,newpm);
2184 POPEVAL(cx);
3280af22 2185 PL_curpm = newpm;
a0a2876f 2186 LEAVE;
a0d0e21e 2187 }
14dd3ad8 2188 JMPENV_POP;
a0d0e21e 2189 }
1e422769 2190
a0d0e21e 2191 if (flags & G_DISCARD) {
3280af22 2192 PL_stack_sp = PL_stack_base + oldmark;
a0d0e21e
LW		 2193 retval = 0;
2194 FREETMPS;
2195 LEAVE;
2196 }
533c011a 2197 PL_op = oldop;
a0d0e21e
LW		 2198 return retval;
2199}
2200
312caa8e 2201STATIC void
dd374669 2202S_call_body(pTHX_ const OP *myop, bool is_eval)
312caa8e 2203{
312caa8e
CS		 2204 if (PL_op == myop) {
2205 if (is_eval)
f807eda9 2206 PL_op = Perl_pp_entereval(aTHX); /* this doesn't do a POPMARK */
312caa8e 2207 else
f807eda9 2208 PL_op = Perl_pp_entersub(aTHX); /* this does */
312caa8e
CS		 2209 }
2210 if (PL_op)
cea2e8a9 2211 CALLRUNOPS(aTHX);
312caa8e
CS		 2212}
2213
6e72f9df 2214/* Eval a string. The G_EVAL flag is always assumed. */
8990e307 2215
954c1994
GS		 2216/*
2217=for apidoc p||eval_sv
2218
2219Tells Perl to C<eval> the string in the SV.
2220
2221=cut
2222*/
2223
a0d0e21e 2224I32
864dbfa3 2225Perl_eval_sv(pTHX_ SV *sv, I32 flags)
ac27b0f5 2226
8ac85365 2227 /* See G_* flags in cop.h */
a0d0e21e 2228{
924508f0 2229 dSP;
a0d0e21e 2230 UNOP myop; /* fake syntax tree node */
8fa7f367 2231 volatile I32 oldmark = SP - PL_stack_base;
13689cfe 2232 volatile I32 retval = 0;
4633a7c4 2233 I32 oldscope;
6224f72b 2234 int ret;
533c011a 2235 OP* oldop = PL_op;
db36c5a1 2236 dJMPENV;
84902520 2237
4633a7c4
LW		 2238 if (flags & G_DISCARD) {
2239 ENTER;
2240 SAVETMPS;
2241 }
2242
462e5cf6 2243 SAVEOP();
533c011a
NIS		 2244 PL_op = (OP*)&myop;
2245 Zero(PL_op, 1, UNOP);
3280af22
NIS		 2246 EXTEND(PL_stack_sp, 1);
2247 *++PL_stack_sp = sv;
2248 oldscope = PL_scopestack_ix;
79072805 2249
4633a7c4
LW		 2250 if (!(flags & G_NOARGS))
2251 myop.op_flags = OPf_STACKED;
79072805 2252 myop.op_next = Nullop;
6e72f9df 2253 myop.op_type = OP_ENTEREVAL;
54310121 2254 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
2255 (flags & G_ARRAY) ? OPf_WANT_LIST :
2256 OPf_WANT_SCALAR);
6e72f9df 2257 if (flags & G_KEEPERR)
2258 myop.op_flags |= OPf_SPECIAL;
4633a7c4 2259
dedbcade
DM		 2260 /* fail now; otherwise we could fail after the JMPENV_PUSH but
2261 * before a PUSHEVAL, which corrupts the stack after a croak */
2262 TAINT_PROPER("eval_sv()");
2263
14dd3ad8 2264 JMPENV_PUSH(ret);
6224f72b
GS		 2265 switch (ret) {
2266 case 0:
14dd3ad8
GS		 2267 redo_body:
2268 call_body((OP*)&myop,TRUE);
312caa8e
CS		 2269 retval = PL_stack_sp - (PL_stack_base + oldmark);
2270 if (!(flags & G_KEEPERR))
2271 sv_setpv(ERRSV,"");
4633a7c4 2272 break;
6224f72b 2273 case 1:
f86702cc 2274 STATUS_ALL_FAILURE;
4633a7c4 2275 /* FALL THROUGH */
6224f72b 2276 case 2:
4633a7c4 2277 /* my_exit() was called */
3280af22 2278 PL_curstash = PL_defstash;
4633a7c4 2279 FREETMPS;
14dd3ad8 2280 JMPENV_POP;
cc3604b1 2281 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
cea2e8a9 2282 Perl_croak(aTHX_ "Callback called exit");
f86702cc 2283 my_exit_jump();
4633a7c4 2284 /* NOTREACHED */
6224f72b 2285 case 3:
3280af22 2286 if (PL_restartop) {
533c011a 2287 PL_op = PL_restartop;
3280af22 2288 PL_restartop = 0;
312caa8e 2289 goto redo_body;
4633a7c4 2290 }
3280af22 2291 PL_stack_sp = PL_stack_base + oldmark;
4633a7c4
LW		 2292 if (flags & G_ARRAY)
2293 retval = 0;
2294 else {
2295 retval = 1;
3280af22 2296 *++PL_stack_sp = &PL_sv_undef;
4633a7c4 2297 }
312caa8e 2298 break;
4633a7c4
LW		 2299 }
2300
14dd3ad8 2301 JMPENV_POP;
4633a7c4 2302 if (flags & G_DISCARD) {
3280af22 2303 PL_stack_sp = PL_stack_base + oldmark;
4633a7c4
LW		 2304 retval = 0;
2305 FREETMPS;
2306 LEAVE;
2307 }
533c011a 2308 PL_op = oldop;
4633a7c4
LW		 2309 return retval;
2310}
2311
954c1994
GS		 2312/*
2313=for apidoc p||eval_pv
2314
2315Tells Perl to C<eval> the given string and return an SV* result.
2316
2317=cut
2318*/
2319
137443ea 2320SV*
864dbfa3 2321Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
137443ea 2322{
2323 dSP;
2324 SV* sv = newSVpv(p, 0);
2325
864dbfa3 2326 eval_sv(sv, G_SCALAR);
137443ea 2327 SvREFCNT_dec(sv);
2328
2329 SPAGAIN;
2330 sv = POPs;
2331 PUTBACK;
2332
2d8e6c8d
GS		 2333 if (croak_on_error && SvTRUE(ERRSV)) {
2334 STRLEN n_a;
cea2e8a9 2335 Perl_croak(aTHX_ SvPVx(ERRSV, n_a));
2d8e6c8d 2336 }
137443ea 2337
2338 return sv;
2339}
2340
4633a7c4
LW		 2341/* Require a module. */
2342
954c1994 2343/*
ccfc67b7
JH		 2344=head1 Embedding Functions
2345
954c1994
GS		 2346=for apidoc p||require_pv
2347
7d3fb230
BS		 2348Tells Perl to C<require> the file named by the string argument. It is
2349analogous to the Perl code C<eval "require '$file'">. It's even
2307c6d0 2350implemented that way; consider using load_module instead.
954c1994 2351
7d3fb230 2352=cut */
954c1994 2353
4633a7c4 2354void
864dbfa3 2355Perl_require_pv(pTHX_ const char *pv)
4633a7c4 2356{
d3acc0f7
JP		 2357 SV* sv;
2358 dSP;
e788e7d3 2359 PUSHSTACKi(PERLSI_REQUIRE);
d3acc0f7
JP		 2360 PUTBACK;
2361 sv = sv_newmortal();
4633a7c4
LW		 2362 sv_setpv(sv, "require '");
2363 sv_catpv(sv, pv);
2364 sv_catpv(sv, "'");
864dbfa3 2365 eval_sv(sv, G_DISCARD);
d3acc0f7
JP		 2366 SPAGAIN;
2367 POPSTACK;
79072805
LW		 2368}
2369
79072805 2370void
e1ec3a88 2371Perl_magicname(pTHX_ const char *sym, const char *name, I32 namlen)
79072805
LW		 2372{
2373 register GV *gv;
2374
155aba94 2375 if ((gv = gv_fetchpv(sym,TRUE, SVt_PV)))
14befaf4 2376 sv_magic(GvSV(gv), (SV*)gv, PERL_MAGIC_sv, name, namlen);
79072805
LW		 2377}
2378
76e3520e 2379STATIC void
e1ec3a88 2380S_usage(pTHX_ const char *name) /* XXX move this out into a module ? */
4633a7c4 2381{
ab821d7f 2382 /* This message really ought to be max 23 lines.
75c72d73 2383 * Removed -h because the user already knows that option. Others? */
fb73857a 2384
bfed75c6 2385 static const char *usage_msg[] = {
fb73857a 2386"-0[octal] specify record separator (\\0, if no argument)",
2387"-a autosplit mode with -n or -p (splits $_ into @F)",
fb3560ee 2388"-C[number/list] enables the listed Unicode features",
1950ee41 2389"-c check syntax only (runs BEGIN and CHECK blocks)",
aac3bd0d
GS		 2390"-d[:debugger] run program under debugger",
2391"-D[number/list] set debugging flags (argument is a bit mask or alphabets)",
90490ea3 2392"-e program one line of program (several -e's allowed, omit programfile)",
20ef40cf 2393"-f don't do $sitelib/sitecustomize.pl at startup",
aac3bd0d
GS		 2394"-F/pattern/ split() pattern for -a switch (//'s are optional)",
2395"-i[extension] edit <> files in place (makes backup if extension supplied)",
2396"-Idirectory specify @INC/#include directory (several -I's allowed)",
fb73857a 2397"-l[octal] enable line ending processing, specifies line terminator",
aac3bd0d
GS		 2398"-[mM][-]module execute `use/no module...' before executing program",
2399"-n assume 'while (<>) { ... }' loop around program",
2400"-p assume loop like -n but print line also, like sed",
2401"-P run program through C preprocessor before compilation",
2402"-s enable rudimentary parsing for switches after programfile",
2403"-S look for programfile using PATH environment variable",
9cbc33e8 2404"-t enable tainting warnings",
90490ea3 2405"-T enable tainting checks",
aac3bd0d 2406"-u dump core after parsing program",
fb73857a 2407"-U allow unsafe operations",
aac3bd0d
GS		 2408"-v print version, subversion (includes VERY IMPORTANT perl info)",
2409"-V[:variable] print configuration summary (or a single Config.pm variable)",
2410"-w enable many useful warnings (RECOMMENDED)",
3c0facb2 2411"-W enable all warnings",
fb73857a 2412"-x[directory] strip off text before #!perl line and perhaps cd to directory",
90490ea3 2413"-X disable all warnings",
fb73857a 2414"\n",
2415NULL
2416};
e1ec3a88 2417 const char **p = usage_msg;
fb73857a 2418
b0e47665
GS		 2419 PerlIO_printf(PerlIO_stdout(),
2420 "\nUsage: %s [switches] [--] [programfile] [arguments]",
2421 name);
fb73857a 2422 while (*p)
b0e47665 2423 PerlIO_printf(PerlIO_stdout(), "\n %s", *p++);
4633a7c4
LW		 2424}
2425
b4ab917c
DM		 2426/* convert a string of -D options (or digits) into an int.
2427 * sets *s to point to the char after the options */
2428
2429#ifdef DEBUGGING
2430int
e1ec3a88 2431Perl_get_debug_opts(pTHX_ const char **s, bool givehelp)
b4ab917c 2432{
bfed75c6 2433 static const char *usage_msgd[] = {
e6e64d9b
JC		 2434 " Debugging flag values: (see also -d)",
2435 " p Tokenizing and parsing (with v, displays parse stack)",
3679267a 2436 " s Stack snapshots (with v, displays all stacks)",
e6e64d9b
JC		 2437 " l Context (loop) stack processing",
2438 " t Trace execution",
2439 " o Method and overloading resolution",
2440 " c String/numeric conversions",
2441 " P Print profiling info, preprocessor command for -P, source file input state",
2442 " m Memory allocation",
2443 " f Format processing",
2444 " r Regular expression parsing and execution",
2445 " x Syntax tree dump",
3679267a 2446 " u Tainting checks",
e6e64d9b
JC		 2447 " H Hash dump -- usurps values()",
2448 " X Scratchpad allocation",
2449 " D Cleaning up",
2450 " S Thread synchronization",
2451 " T Tokenising",
2452 " R Include reference counts of dumped variables (eg when using -Ds)",
2453 " J Do not s,t,P-debug (Jump over) opcodes within package DB",
2454 " v Verbose: use in conjunction with other flags",
2455 " C Copy On Write",
2456 " A Consistency checks on internal structures",
3679267a 2457 " q quiet - currently only suppresses the 'EXECUTING' message",
e6e64d9b
JC		 2458 NULL
2459 };
b4ab917c
DM		 2460 int i = 0;
2461 if (isALPHA(**s)) {
2462 /* if adding extra options, remember to update DEBUG_MASK */
bfed75c6 2463 static const char debopts[] = "psltocPmfrxu HXDSTRJvCAq";
b4ab917c
DM		 2464
2465 for (; isALNUM(**s); (*s)++) {
e1ec3a88 2466 const char *d = strchr(debopts,**s);
b4ab917c
DM		 2467 if (d)
2468 i |= 1 << (d - debopts);
2469 else if (ckWARN_d(WARN_DEBUGGING))
e6e64d9b
JC		 2470 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
2471 "invalid option -D%c, use -D'' to see choices\n", **s);
b4ab917c
DM		 2472 }
2473 }
e6e64d9b 2474 else if (isDIGIT(**s)) {
b4ab917c
DM		 2475 i = atoi(*s);
2476 for (; isALNUM(**s); (*s)++) ;
2477 }
ddcf8bc1 2478 else if (givehelp) {
e1ec3a88 2479 const char **p = usage_msgd;
e6e64d9b
JC		 2480 while (*p) PerlIO_printf(PerlIO_stdout(), "%s\n", *p++);
2481 }
b4ab917c
DM		 2482# ifdef EBCDIC
2483 if ((i & DEBUG_p_FLAG) && ckWARN_d(WARN_DEBUGGING))
2484 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
2485 "-Dp not implemented on this platform\n");
2486# endif
2487 return i;
2488}
2489#endif
2490
79072805
LW		 2491/* This routine handles any switches that can be given during run */
2492
2493char *
864dbfa3 2494Perl_moreswitches(pTHX_ char *s)
79072805 2495{
ba210ebe 2496 STRLEN numlen;
84c133a0 2497 UV rschar;
79072805
LW		 2498
2499 switch (*s) {
2500 case '0':
a863c7d1 2501 {
f2095865
JH		 2502 I32 flags = 0;
2503
2504 SvREFCNT_dec(PL_rs);
2505 if (s[1] == 'x' && s[2]) {
2506 char *e;
2507 U8 *tmps;
2508
2509 for (s += 2, e = s; *e; e++);
2510 numlen = e - s;
2511 flags = PERL_SCAN_SILENT_ILLDIGIT;
2512 rschar = (U32)grok_hex(s, &numlen, &flags, NULL);
2513 if (s + numlen < e) {
2514 rschar = 0; /* Grandfather -0xFOO as -0 -xFOO. */
2515 numlen = 0;
2516 s--;
2517 }
2518 PL_rs = newSVpvn("", 0);
c5661c80 2519 SvGROW(PL_rs, (STRLEN)(UNISKIP(rschar) + 1));
f2095865
JH		 2520 tmps = (U8*)SvPVX(PL_rs);
2521 uvchr_to_utf8(tmps, rschar);
2522 SvCUR_set(PL_rs, UNISKIP(rschar));
2523 SvUTF8_on(PL_rs);
2524 }
2525 else {
2526 numlen = 4;
2527 rschar = (U32)grok_oct(s, &numlen, &flags, NULL);
2528 if (rschar & ~((U8)~0))
2529 PL_rs = &PL_sv_undef;
2530 else if (!rschar && numlen >= 2)
2531 PL_rs = newSVpvn("", 0);
2532 else {
2533 char ch = (char)rschar;
2534 PL_rs = newSVpvn(&ch, 1);
2535 }
2536 }
800633c3 2537 sv_setsv(get_sv("/", TRUE), PL_rs);
f2095865 2538 return s + numlen;
a863c7d1 2539 }
46487f74 2540 case 'C':
a05d7ebb 2541 s++;
dd374669 2542 PL_unicode = parse_unicode_opts( (const char **)&s );
46487f74 2543 return s;
2304df62 2544 case 'F':
3280af22 2545 PL_minus_F = TRUE;
ebce5377
RGS		 2546 PL_splitstr = ++s;
2547 while (*s && !isSPACE(*s)) ++s;
2548 *s = '\0';
2549 PL_splitstr = savepv(PL_splitstr);
2304df62 2550 return s;
79072805 2551 case 'a':
3280af22 2552 PL_minus_a = TRUE;
79072805
LW		 2553 s++;
2554 return s;
2555 case 'c':
3280af22 2556 PL_minus_c = TRUE;
79072805
LW		 2557 s++;
2558 return s;
2559 case 'd':
bbce6d69 2560 forbid_setid("-d");
4633a7c4 2561 s++;
2cbb2ee1
RGS		 2562
2563 /* -dt indicates to the debugger that threads will be used */
2564 if (*s == 't' && !isALNUM(s[1])) {
2565 ++s;
2566 my_setenv("PERL5DB_THREADED", "1");
2567 }
2568
70c94a19
RR		 2569 /* The following permits -d:Mod to accepts arguments following an =
2570 in the fashion that -MSome::Mod does. */
2571 if (*s == ':' || *s == '=') {
06b5626a 2572 const char *start;
70c94a19
RR		 2573 SV *sv;
2574 sv = newSVpv("use Devel::", 0);
2575 start = ++s;
2576 /* We now allow -d:Module=Foo,Bar */
2577 while(isALNUM(*s) || *s==':') ++s;
2578 if (*s != '=')
2579 sv_catpv(sv, start);
2580 else {
2581 sv_catpvn(sv, start, s-start);
2582 sv_catpv(sv, " split(/,/,q{");
2583 sv_catpv(sv, ++s);
3d27e215 2584 sv_catpv(sv, "})");
70c94a19 2585 }
4633a7c4 2586 s += strlen(s);
70c94a19 2587 my_setenv("PERL5DB", SvPV(sv, PL_na));
4633a7c4 2588 }
ed094faf 2589 if (!PL_perldb) {
3280af22 2590 PL_perldb = PERLDB_ALL;
a0d0e21e 2591 init_debugger();
ed094faf 2592 }
79072805
LW		 2593 return s;
2594 case 'D':
0453d815 2595 {
79072805 2596#ifdef DEBUGGING
bbce6d69 2597 forbid_setid("-D");
b4ab917c 2598 s++;
dd374669 2599 PL_debug = get_debug_opts( (const char **)&s, 1) | DEBUG_TOP_FLAG;
12a43e32 2600#else /* !DEBUGGING */
0453d815 2601 if (ckWARN_d(WARN_DEBUGGING))
9014280d 2602 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
e6e64d9b 2603 "Recompile perl with -DDEBUGGING to use -D switch (did you mean -d ?)\n");
a0d0e21e 2604 for (s++; isALNUM(*s); s++) ;
79072805
LW		 2605#endif
2606 /*SUPPRESS 530*/
2607 return s;
0453d815 2608 }
4633a7c4 2609 case 'h':
ac27b0f5 2610 usage(PL_origargv[0]);
7ca617d0 2611 my_exit(0);
79072805 2612 case 'i':
3280af22
NIS		 2613 if (PL_inplace)
2614 Safefree(PL_inplace);
c030f24b
GH		 2615#if defined(__CYGWIN__) /* do backup extension automagically */
2616 if (*(s+1) == '\0') {
2617 PL_inplace = savepv(".bak");
2618 return s+1;
2619 }
2620#endif /* __CYGWIN__ */
3280af22 2621 PL_inplace = savepv(s+1);
79072805 2622 /*SUPPRESS 530*/
3280af22 2623 for (s = PL_inplace; *s && !isSPACE(*s); s++) ;
7b8d334a 2624 if (*s) {
fb73857a 2625 *s++ = '\0';
7b8d334a
GS		 2626 if (*s == '-') /* Additional switches on #! line. */
2627 s++;
2628 }
fb73857a 2629 return s;
4e49a025 2630 case 'I': /* -I handled both here and in parse_body() */
bbce6d69 2631 forbid_setid("-I");
fb73857a 2632 ++s;
2633 while (*s && isSPACE(*s))
2634 ++s;
2635 if (*s) {
774d564b 2636 char *e, *p;
0df16ed7
GS		 2637 p = s;
2638 /* ignore trailing spaces (possibly followed by other switches) */
2639 do {
2640 for (e = p; *e && !isSPACE(*e); e++) ;
2641 p = e;
2642 while (isSPACE(*p))
2643 p++;
2644 } while (*p && *p != '-');
2645 e = savepvn(s, e-s);
88fe16b2 2646 incpush(e, TRUE, TRUE, FALSE, FALSE);
0df16ed7
GS		 2647 Safefree(e);
2648 s = p;
2649 if (*s == '-')
2650 s++;
79072805
LW		 2651 }
2652 else
a67e862a 2653 Perl_croak(aTHX_ "No directory specified for -I");
fb73857a 2654 return s;
79072805 2655 case 'l':
3280af22 2656 PL_minus_l = TRUE;
79072805 2657 s++;
7889fe52
NIS		 2658 if (PL_ors_sv) {
2659 SvREFCNT_dec(PL_ors_sv);
2660 PL_ors_sv = Nullsv;
2661 }
79072805 2662 if (isDIGIT(*s)) {
53305cf1 2663 I32 flags = 0;
7889fe52 2664 PL_ors_sv = newSVpvn("\n",1);
53305cf1
NC		 2665 numlen = 3 + (*s == '0');
2666 *SvPVX(PL_ors_sv) = (char)grok_oct(s, &numlen, &flags, NULL);
79072805
LW		 2667 s += numlen;
2668 }
2669 else {
8bfdd7d9 2670 if (RsPARA(PL_rs)) {
7889fe52
NIS		 2671 PL_ors_sv = newSVpvn("\n\n",2);
2672 }
2673 else {
8bfdd7d9 2674 PL_ors_sv = newSVsv(PL_rs);
c07a80fd 2675 }
79072805
LW		 2676 }
2677 return s;
06492da6
SF		 2678 case 'A':
2679 forbid_setid("-A");
930366bd
RGS		 2680 if (!PL_preambleav)
2681 PL_preambleav = newAV();
06492da6 2682 if (*++s) {
3d27e215
LM		 2683 SV *sv = newSVpv("use assertions::activate split(/,/,q", 0);
2684 sv_catpvn(sv, "\0", 1); /* Use NUL as q//-delimiter. */
06492da6 2685 sv_catpv(sv,s);
3d27e215 2686 sv_catpvn(sv, "\0)", 2);
06492da6 2687 s+=strlen(s);
06492da6
SF		 2688 av_push(PL_preambleav, sv);
2689 }
2690 else
930366bd 2691 av_push(PL_preambleav, newSVpvn("use assertions::activate",24));
06492da6 2692 return s;
1a30305b 2693 case 'M':
bbce6d69 2694 forbid_setid("-M"); /* XXX ? */
1a30305b 2695 /* FALL THROUGH */
2696 case 'm':
bbce6d69 2697 forbid_setid("-m"); /* XXX ? */
1a30305b 2698 if (*++s) {
a5f75d66 2699 char *start;
11343788 2700 SV *sv;
e1ec3a88 2701 const char *use = "use ";
a5f75d66
AD		 2702 /* -M-foo == 'no foo' */
2703 if (*s == '-') { use = "no "; ++s; }
11343788 2704 sv = newSVpv(use,0);
a5f75d66 2705 start = s;
1a30305b 2706 /* We allow -M'Module qw(Foo Bar)' */
c07a80fd 2707 while(isALNUM(*s) || *s==':') ++s;
2708 if (*s != '=') {
11343788 2709 sv_catpv(sv, start);
c07a80fd 2710 if (*(start-1) == 'm') {
2711 if (*s != '\0')
cea2e8a9 2712 Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
11343788 2713 sv_catpv( sv, " ()");
c07a80fd 2714 }
2715 } else {
6df41af2 2716 if (s == start)
be98fb35
GS		 2717 Perl_croak(aTHX_ "Module name required with -%c option",
2718 s[-1]);
11343788 2719 sv_catpvn(sv, start, s-start);
3d27e215
LM		 2720 sv_catpv(sv, " split(/,/,q");
2721 sv_catpvn(sv, "\0)", 1); /* Use NUL as q//-delimiter. */
11343788 2722 sv_catpv(sv, ++s);
3d27e215 2723 sv_catpvn(sv, "\0)", 2);
c07a80fd 2724 }
1a30305b 2725 s += strlen(s);
5c831c24 2726 if (!PL_preambleav)
3280af22
NIS		 2727 PL_preambleav = newAV();
2728 av_push(PL_preambleav, sv);
1a30305b 2729 }
2730 else
9e81e6a1 2731 Perl_croak(aTHX_ "Missing argument to -%c", *(s-1));
1a30305b 2732 return s;
79072805 2733 case 'n':
3280af22 2734 PL_minus_n = TRUE;
79072805
LW		 2735 s++;
2736 return s;
2737 case 'p':
3280af22 2738 PL_minus_p = TRUE;
79072805
LW		 2739 s++;
2740 return s;
2741 case 's':
bbce6d69 2742 forbid_setid("-s");
3280af22 2743 PL_doswitches = TRUE;
79072805
LW		 2744 s++;
2745 return s;
6537fe72
MS		 2746 case 't':
2747 if (!PL_tainting)
22f7c9c9 2748 TOO_LATE_FOR('t');
6537fe72
MS		 2749 s++;
2750 return s;
463ee0b2 2751 case 'T':
3280af22 2752 if (!PL_tainting)
22f7c9c9 2753 TOO_LATE_FOR('T');
463ee0b2
LW		 2754 s++;
2755 return s;
79072805 2756 case 'u':
bf4acbe4
GS		 2757#ifdef MACOS_TRADITIONAL
2758 Perl_croak(aTHX_ "Believe me, you don't want to use \"-u\" on a Macintosh");
2759#endif
3280af22 2760 PL_do_undump = TRUE;
79072805
LW		 2761 s++;
2762 return s;
2763 case 'U':
3280af22 2764 PL_unsafe = TRUE;
79072805
LW		 2765 s++;
2766 return s;
2767 case 'v':
d7aa5382
JP		 2768 if (!sv_derived_from(PL_patchlevel, "version"))
2769 (void *)upg_version(PL_patchlevel);
8e9464f1 2770#if !defined(DGUX)
b0e47665 2771 PerlIO_printf(PerlIO_stdout(),
014ead4b 2772 Perl_form(aTHX_ "\nThis is perl, v%"SVf" built for %s",
d7aa5382
JP		 2773 vstringify(PL_patchlevel),
2774 ARCHNAME));
8e9464f1
JH		 2775#else /* DGUX */
2776/* Adjust verbose output as in the perl that ships with the DG/UX OS from EMC */
2777 PerlIO_printf(PerlIO_stdout(),
014ead4b 2778 Perl_form(aTHX_ "\nThis is perl, v%"SVf"\n",
d7aa5382 2779 vstringify(PL_patchlevel)));
8e9464f1
JH		 2780 PerlIO_printf(PerlIO_stdout(),
2781 Perl_form(aTHX_ " built under %s at %s %s\n",
2782 OSNAME, __DATE__, __TIME__));
2783 PerlIO_printf(PerlIO_stdout(),
2784 Perl_form(aTHX_ " OS Specific Release: %s\n",
40a39f85 2785 OSVERS));
8e9464f1
JH		 2786#endif /* !DGUX */
2787
fb73857a 2788#if defined(LOCAL_PATCH_COUNT)
2789 if (LOCAL_PATCH_COUNT > 0)
b0e47665
GS		 2790 PerlIO_printf(PerlIO_stdout(),
2791 "\n(with %d registered patch%s, "
2792 "see perl -V for more detail)",
2793 (int)LOCAL_PATCH_COUNT,
2794 (LOCAL_PATCH_COUNT!=1) ? "es" : "");
a5f75d66 2795#endif
1a30305b 2796
b0e47665 2797 PerlIO_printf(PerlIO_stdout(),
359b00fe 2798 "\n\nCopyright 1987-2005, Larry Wall\n");
eae9c151
JH		 2799#ifdef MACOS_TRADITIONAL
2800 PerlIO_printf(PerlIO_stdout(),
be3c0a43 2801 "\nMac OS port Copyright 1991-2002, Matthias Neeracher;\n"
03765510 2802 "maintained by Chris Nandor\n");
eae9c151 2803#endif
79072805 2804#ifdef MSDOS
b0e47665
GS		 2805 PerlIO_printf(PerlIO_stdout(),
2806 "\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
55497cff 2807#endif
2808#ifdef DJGPP
b0e47665
GS		 2809 PerlIO_printf(PerlIO_stdout(),
2810 "djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n"
2811 "djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
4633a7c4 2812#endif
79072805 2813#ifdef OS2
b0e47665
GS		 2814 PerlIO_printf(PerlIO_stdout(),
2815 "\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
be3c0a43 2816 "Version 5 port Copyright (c) 1994-2002, Andreas Kaiser, Ilya Zakharevich\n");
79072805 2817#endif
79072805 2818#ifdef atarist
b0e47665
GS		 2819 PerlIO_printf(PerlIO_stdout(),
2820 "atariST series port, ++jrb bammi@cadence.com\n");
79072805 2821#endif
a3f9223b 2822#ifdef __BEOS__
b0e47665
GS		 2823 PerlIO_printf(PerlIO_stdout(),
2824 "BeOS port Copyright Tom Spindler, 1997-1999\n");
a3f9223b 2825#endif
1d84e8df 2826#ifdef MPE
b0e47665 2827 PerlIO_printf(PerlIO_stdout(),
e583a879 2828 "MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-2003\n");
1d84e8df 2829#endif
9d116dd7 2830#ifdef OEMVS
b0e47665
GS		 2831 PerlIO_printf(PerlIO_stdout(),
2832 "MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
9d116dd7 2833#endif
495c5fdc 2834#ifdef __VOS__
b0e47665 2835 PerlIO_printf(PerlIO_stdout(),
94efb9fb 2836 "Stratus VOS port by Paul.Green@stratus.com, 1997-2002\n");
495c5fdc 2837#endif
092bebab 2838#ifdef __OPEN_VM
b0e47665
GS		 2839 PerlIO_printf(PerlIO_stdout(),
2840 "VM/ESA port by Neale Ferguson, 1998-1999\n");
092bebab 2841#endif
a1a0e61e 2842#ifdef POSIX_BC
b0e47665
GS		 2843 PerlIO_printf(PerlIO_stdout(),
2844 "BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
a1a0e61e 2845#endif
61ae2fbf 2846#ifdef __MINT__
b0e47665
GS		 2847 PerlIO_printf(PerlIO_stdout(),
2848 "MiNT port by Guido Flohr, 1997-1999\n");
61ae2fbf 2849#endif
f83d2536 2850#ifdef EPOC
b0e47665 2851 PerlIO_printf(PerlIO_stdout(),
be3c0a43 2852 "EPOC port by Olaf Flebbe, 1999-2002\n");
f83d2536 2853#endif
e1caacb4 2854#ifdef UNDER_CE
b475b3e6
JH		 2855 PerlIO_printf(PerlIO_stdout(),"WINCE port by Rainer Keuchel, 2001-2002\n");
2856 PerlIO_printf(PerlIO_stdout(),"Built on " __DATE__ " " __TIME__ "\n\n");
e1caacb4
JH		 2857 wce_hitreturn();
2858#endif
baed7233
DL		 2859#ifdef BINARY_BUILD_NOTICE
2860 BINARY_BUILD_NOTICE;
2861#endif
b0e47665
GS		 2862 PerlIO_printf(PerlIO_stdout(),
2863 "\n\
79072805 2864Perl may be copied only under the terms of either the Artistic License or the\n\
3d6f292d 2865GNU General Public License, which may be found in the Perl 5 source kit.\n\n\
95103687
GS		 2866Complete documentation for Perl, including FAQ lists, should be found on\n\
2867this system using `man perl' or `perldoc perl'. If you have access to the\n\
c9e30dd8 2868Internet, point your browser at http://www.perl.org/, the Perl Home Page.\n\n");
7ca617d0 2869 my_exit(0);
79072805 2870 case 'w':
599cee73 2871 if (! (PL_dowarn & G_WARN_ALL_MASK))
ac27b0f5 2872 PL_dowarn |= G_WARN_ON;
599cee73
PM		 2873 s++;
2874 return s;
2875 case 'W':
ac27b0f5 2876 PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
317ea90d
MS		 2877 if (!specialWARN(PL_compiling.cop_warnings))
2878 SvREFCNT_dec(PL_compiling.cop_warnings);
d3a7d8c7 2879 PL_compiling.cop_warnings = pWARN_ALL ;
599cee73
PM		 2880 s++;
2881 return s;
2882 case 'X':
ac27b0f5 2883 PL_dowarn = G_WARN_ALL_OFF;
317ea90d
MS		 2884 if (!specialWARN(PL_compiling.cop_warnings))
2885 SvREFCNT_dec(PL_compiling.cop_warnings);
d3a7d8c7 2886 PL_compiling.cop_warnings = pWARN_NONE ;
79072805
LW		 2887 s++;
2888 return s;
a0d0e21e 2889 case '*':
79072805
LW		 2890 case ' ':
2891 if (s[1] == '-') /* Additional switches on #! line. */
2892 return s+2;
2893 break;
a0d0e21e 2894 case '-':
79072805 2895 case 0:
51882d45 2896#if defined(WIN32) || !defined(PERL_STRICT_CR)
a868473f
NIS		 2897 case '\r':
2898#endif
79072805
LW		 2899 case '\n':
2900 case '\t':
2901 break;
aa689395 2902#ifdef ALTERNATE_SHEBANG
2903 case 'S': /* OS/2 needs -S on "extproc" line. */
2904 break;
2905#endif
a0d0e21e 2906 case 'P':
3280af22 2907 if (PL_preprocess)
a0d0e21e
LW		 2908 return s+1;
2909 /* FALL THROUGH */
79072805 2910 default:
cea2e8a9 2911 Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
79072805
LW		 2912 }
2913 return Nullch;
2914}
2915
2916/* compliments of Tom Christiansen */
2917
2918/* unexec() can be found in the Gnu emacs distribution */
ee580363 2919/* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
79072805
LW		 2920
2921void
864dbfa3 2922Perl_my_unexec(pTHX)
79072805
LW		 2923{
2924#ifdef UNEXEC
46fc3d4c 2925 SV* prog;
2926 SV* file;
ee580363 2927 int status = 1;
79072805
LW		 2928 extern int etext;
2929
ee580363 2930 prog = newSVpv(BIN_EXP, 0);
46fc3d4c 2931 sv_catpv(prog, "/perl");
6b88bc9c 2932 file = newSVpv(PL_origfilename, 0);
46fc3d4c 2933 sv_catpv(file, ".perldump");
79072805 2934
ee580363
GS		 2935 unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
2936 /* unexec prints msg to stderr in case of failure */
6ad3d225 2937 PerlProc_exit(status);
79072805 2938#else
a5f75d66
AD		 2939# ifdef VMS
2940# include <lib$routines.h>
2941 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
aa689395 2942# else
79072805 2943 ABORT(); /* for use with undump */
aa689395 2944# endif
a5f75d66 2945#endif
79072805
LW		 2946}
2947
cb68f92d
GS		 2948/* initialize curinterp */
2949STATIC void
cea2e8a9 2950S_init_interp(pTHX)
cb68f92d
GS		 2951{
2952
acfe0abc
GS		 2953#ifdef MULTIPLICITY
2954# define PERLVAR(var,type)
2955# define PERLVARA(var,n,type)
2956# if defined(PERL_IMPLICIT_CONTEXT)
2957# if defined(USE_5005THREADS)
2958# define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
c5be433b 2959# define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
acfe0abc
GS		 2960# else /* !USE_5005THREADS */
2961# define PERLVARI(var,type,init) aTHX->var = init;
2962# define PERLVARIC(var,type,init) aTHX->var = init;
2963# endif /* USE_5005THREADS */
3967c732 2964# else
acfe0abc
GS		 2965# define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
2966# define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
066ef5b5 2967# endif
acfe0abc
GS		 2968# include "intrpvar.h"
2969# ifndef USE_5005THREADS
2970# include "thrdvar.h"
2971# endif
2972# undef PERLVAR
2973# undef PERLVARA
2974# undef PERLVARI
2975# undef PERLVARIC
2976#else
2977# define PERLVAR(var,type)
2978# define PERLVARA(var,n,type)
2979# define PERLVARI(var,type,init) PL_##var = init;
2980# define PERLVARIC(var,type,init) PL_##var = init;
2981# include "intrpvar.h"
2982# ifndef USE_5005THREADS
2983# include "thrdvar.h"
2984# endif
2985# undef PERLVAR
2986# undef PERLVARA
2987# undef PERLVARI
2988# undef PERLVARIC
cb68f92d
GS		 2989#endif
2990
cb68f92d
GS		 2991}
2992
76e3520e 2993STATIC void
cea2e8a9 2994S_init_main_stash(pTHX)
79072805 2995{
463ee0b2 2996 GV *gv;
6e72f9df 2997
3280af22 2998 PL_curstash = PL_defstash = newHV();
79cb57f6 2999 PL_curstname = newSVpvn("main",4);
adbc6bb1
LW		 3000 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
3001 SvREFCNT_dec(GvHV(gv));
3280af22 3002 GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);
463ee0b2 3003 SvREADONLY_on(gv);
ff5bdd37 3004 HvNAME(PL_defstash) = savepvn("main", 4);
3280af22
NIS		 3005 PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
3006 GvMULTI_on(PL_incgv);
3007 PL_hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */
3008 GvMULTI_on(PL_hintgv);
3009 PL_defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
3010 PL_errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
3011 GvMULTI_on(PL_errgv);
3012 PL_replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */
3013 GvMULTI_on(PL_replgv);
cea2e8a9 3014 (void)Perl_form(aTHX_ "%240s",""); /* Preallocate temp - for immediate signals. */
38a03e6e
MB		 3015 sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
3016 sv_setpvn(ERRSV, "", 0);
3280af22 3017 PL_curstash = PL_defstash;
11faa288 3018 CopSTASH_set(&PL_compiling, PL_defstash);
ed094faf 3019 PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
3280af22 3020 PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
4633a7c4 3021 /* We must init $/ before switches are processed. */
864dbfa3 3022 sv_setpvn(get_sv("/", TRUE), "\n", 1);
79072805
LW		 3023}
3024
ae3f3efd 3025/* PSz 18 Nov 03 fdscript now global but do not change prototype */
76e3520e 3026STATIC void
dd374669 3027S_open_script(pTHX_ const char *scriptname, bool dosearch, SV *sv)
79072805 3028{
ae3f3efd 3029#ifndef IAMSUID
e1ec3a88
AL		 3030 const char *quote;
3031 const char *code;
3032 const char *cpp_discard_flag;
3033 const char *perl;
ae3f3efd 3034#endif
1b24ed4b 3035
ae3f3efd
PS		 3036 PL_fdscript = -1;
3037 PL_suidscript = -1;
79072805 3038
3280af22 3039 if (PL_e_script) {
ff5bdd37 3040 PL_origfilename = savepvn("-e", 2);
96436eeb 3041 }
6c4ab083
GS		 3042 else {
3043 /* if find_script() returns, it returns a malloc()-ed value */
dd374669 3044 scriptname = PL_origfilename = find_script(scriptname, dosearch, NULL, 1);
6c4ab083
GS		 3045
3046 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
e1ec3a88 3047 const char *s = scriptname + 8;
ae3f3efd 3048 PL_fdscript = atoi(s);
6c4ab083
GS		 3049 while (isDIGIT(*s))
3050 s++;
3051 if (*s) {
ae3f3efd
PS		 3052 /* PSz 18 Feb 04
3053 * Tell apart "normal" usage of fdscript, e.g.
3054 * with bash on FreeBSD:
3055 * perl <( echo '#!perl -DA'; echo 'print "$0\n"')
3056 * from usage in suidperl.
3057 * Does any "normal" usage leave garbage after the number???
3058 * Is it a mistake to use a similar /dev/fd/ construct for
3059 * suidperl?
3060 */
3061 PL_suidscript = 1;
3062 /* PSz 20 Feb 04
3063 * Be supersafe and do some sanity-checks.
3064 * Still, can we be sure we got the right thing?
3065 */
3066 if (*s != '/') {
3067 Perl_croak(aTHX_ "Wrong syntax (suid) fd script name \"%s\"\n", s);
3068 }
3069 if (! *(s+1)) {
3070 Perl_croak(aTHX_ "Missing (suid) fd script name\n");
3071 }
6c4ab083 3072 scriptname = savepv(s + 1);
3280af22 3073 Safefree(PL_origfilename);
dd374669 3074 PL_origfilename = (char *)scriptname;
6c4ab083
GS		 3075 }
3076 }
3077 }
3078
05ec9bb3 3079 CopFILE_free(PL_curcop);
57843af0 3080 CopFILE_set(PL_curcop, PL_origfilename);
770526c1 3081 if (*PL_origfilename == '-' && PL_origfilename[1] == '\0')
dd374669 3082 scriptname = (char *)"";
ae3f3efd
PS		 3083 if (PL_fdscript >= 0) {
3084 PL_rsfp = PerlIO_fdopen(PL_fdscript,PERL_SCRIPT_MODE);
1b24ed4b
MS		 3085# if defined(HAS_FCNTL) && defined(F_SETFD)
3086 if (PL_rsfp)
3087 /* ensure close-on-exec */
3088 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);
3089# endif
96436eeb 3090 }
ae3f3efd
PS		 3091#ifdef IAMSUID
3092 else {
86207487
NC		 3093 Perl_croak(aTHX_ "sperl needs fd script\n"
3094 "You should not call sperl directly; do you need to "
3095 "change a #! line\nfrom sperl to perl?\n");
3096
ae3f3efd
PS		 3097/* PSz 11 Nov 03
3098 * Do not open (or do other fancy stuff) while setuid.
3099 * Perl does the open, and hands script to suidperl on a fd;
3100 * suidperl only does some checks, sets up UIDs and re-execs
3101 * perl with that fd as it has always done.
3102 */
3103 }
3104 if (PL_suidscript != 1) {
3105 Perl_croak(aTHX_ "suidperl needs (suid) fd script\n");
3106 }
3107#else /* IAMSUID */
3280af22 3108 else if (PL_preprocess) {
dd374669 3109 const char *cpp_cfg = CPPSTDIN;
79cb57f6 3110 SV *cpp = newSVpvn("",0);
46fc3d4c 3111 SV *cmd = NEWSV(0,0);
3112
ae58f265
JH		 3113 if (cpp_cfg[0] == 0) /* PERL_MICRO? */
3114 Perl_croak(aTHX_ "Can't run with cpp -P with CPPSTDIN undefined");
46fc3d4c 3115 if (strEQ(cpp_cfg, "cppstdin"))
cea2e8a9 3116 Perl_sv_catpvf(aTHX_ cpp, "%s/", BIN_EXP);
46fc3d4c 3117 sv_catpv(cpp, cpp_cfg);
79072805 3118
1b24ed4b
MS		 3119# ifndef VMS
3120 sv_catpvn(sv, "-I", 2);
3121 sv_catpv(sv,PRIVLIB_EXP);
3122# endif
46fc3d4c 3123
14953ddc
MB		 3124 DEBUG_P(PerlIO_printf(Perl_debug_log,
3125 "PL_preprocess: scriptname=\"%s\", cpp=\"%s\", sv=\"%s\", CPPMINUS=\"%s\"\n",
3126 scriptname, SvPVX (cpp), SvPVX (sv), CPPMINUS));
1b24ed4b
MS		 3127
3128# if defined(MSDOS) || defined(WIN32) || defined(VMS)
3129 quote = "\"";
3130# else
3131 quote = "'";
3132# endif
3133
3134# ifdef VMS
3135 cpp_discard_flag = "";
3136# else
3137 cpp_discard_flag = "-C";
3138# endif
3139
3140# ifdef OS2
3141 perl = os2_execname(aTHX);
3142# else
3143 perl = PL_origargv[0];
3144# endif
3145
3146
3147 /* This strips off Perl comments which might interfere with
62375a60
NIS		 3148 the C pre-processor, including #!. #line directives are
3149 deliberately stripped to avoid confusion with Perl's version
1b24ed4b
MS		 3150 of #line. FWP played some golf with it so it will fit
3151 into VMS's 255 character buffer.
3152 */
3153 if( PL_doextract )
3154 code = "(1../^#!.*perl/i)|/^\\s*#(?!\\s*((ifn?|un)def|(el|end)?if|define|include|else|error|pragma)\\b)/||!($|=1)||print";
3155 else
3156 code = "/^\\s*#(?!\\s*((ifn?|un)def|(el|end)?if|define|include|else|error|pragma)\\b)/||!($|=1)||print";
3157
3158 Perl_sv_setpvf(aTHX_ cmd, "\
3159%s -ne%s%s%s %s | %"SVf" %s %"SVf" %s",
62375a60 3160 perl, quote, code, quote, scriptname, cpp,
1b24ed4b
MS		 3161 cpp_discard_flag, sv, CPPMINUS);
3162
3280af22 3163 PL_doextract = FALSE;
0a6c758d 3164
62375a60
NIS		 3165 DEBUG_P(PerlIO_printf(Perl_debug_log,
3166 "PL_preprocess: cmd=\"%s\"\n",
0a6c758d
MS		 3167 SvPVX(cmd)));
3168
dd374669 3169 PL_rsfp = PerlProc_popen(SvPVX(cmd), (char *)"r");
46fc3d4c 3170 SvREFCNT_dec(cmd);
3171 SvREFCNT_dec(cpp);
79072805
LW		 3172 }
3173 else if (!*scriptname) {
bbce6d69 3174 forbid_setid("program input from stdin");
3280af22 3175 PL_rsfp = PerlIO_stdin();
79072805 3176 }
96436eeb 3177 else {
3280af22 3178 PL_rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
1b24ed4b
MS		 3179# if defined(HAS_FCNTL) && defined(F_SETFD)
3180 if (PL_rsfp)
3181 /* ensure close-on-exec */
3182 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);
3183# endif
96436eeb 3184 }
ae3f3efd 3185#endif /* IAMSUID */
3280af22 3186 if (!PL_rsfp) {
447218f8 3187 /* PSz 16 Sep 03 Keep neat error message */
fa3aa65a
JC		 3188 Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
3189 CopFILE(PL_curcop), Strerror(errno));
13281fa4 3190 }
79072805 3191}
8d063cd8 3192
7b89560d
JH		 3193/* Mention
3194 * I_SYSSTATVFS HAS_FSTATVFS
3195 * I_SYSMOUNT
c890dc6c 3196 * I_STATFS HAS_FSTATFS HAS_GETFSSTAT
7b89560d
JH		 3197 * I_MNTENT HAS_GETMNTENT HAS_HASMNTOPT
3198 * here so that metaconfig picks them up. */
3199
104d25b7 3200#ifdef IAMSUID
864dbfa3 3201STATIC int
e688b231 3202S_fd_on_nosuid_fs(pTHX_ int fd)
104d25b7 3203{
ae3f3efd
PS		 3204/* PSz 27 Feb 04
3205 * We used to do this as "plain" user (after swapping UIDs with setreuid);
3206 * but is needed also on machines without setreuid.
3207 * Seems safe enough to run as root.
3208 */
0545a864
JH		 3209 int check_okay = 0; /* able to do all the required sys/libcalls */
3210 int on_nosuid = 0; /* the fd is on a nosuid fs */
ae3f3efd
PS		 3211 /* PSz 12 Nov 03
3212 * Need to check noexec also: nosuid might not be set, the average
3213 * sysadmin would say that nosuid is irrelevant once he sets noexec.
3214 */
3215 int on_noexec = 0; /* the fd is on a noexec fs */
3216
104d25b7 3217/*
ad27e871 3218 * Preferred order: fstatvfs(), fstatfs(), ustat()+getmnt(), getmntent().
e688b231 3219 * fstatvfs() is UNIX98.
0545a864 3220 * fstatfs() is 4.3 BSD.
ad27e871 3221 * ustat()+getmnt() is pre-4.3 BSD.
0545a864
JH		 3222 * getmntent() is O(number-of-mounted-filesystems) and can hang on
3223 * an irrelevant filesystem while trying to reach the right one.
104d25b7
JH		 3224 */
3225
6439433f
JH		 3226#undef FD_ON_NOSUID_CHECK_OKAY /* found the syscalls to do the check? */
3227
3228# if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
3229 defined(HAS_FSTATVFS)
3230# define FD_ON_NOSUID_CHECK_OKAY
104d25b7 3231 struct statvfs stfs;
6439433f 3232
104d25b7
JH		 3233 check_okay = fstatvfs(fd, &stfs) == 0;
3234 on_nosuid = check_okay && (stfs.f_flag & ST_NOSUID);
ae3f3efd
PS		 3235#ifdef ST_NOEXEC
3236 /* ST_NOEXEC certainly absent on AIX 5.1, and doesn't seem to be documented
3237 on platforms where it is present. */
3238 on_noexec = check_okay && (stfs.f_flag & ST_NOEXEC);
3239#endif
6439433f 3240# endif /* fstatvfs */
ac27b0f5 3241
6439433f
JH		 3242# if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
3243 defined(PERL_MOUNT_NOSUID) && \
ae3f3efd 3244 defined(PERL_MOUNT_NOEXEC) && \
6439433f
JH		 3245 defined(HAS_FSTATFS) && \
3246 defined(HAS_STRUCT_STATFS) && \
3247 defined(HAS_STRUCT_STATFS_F_FLAGS)
3248# define FD_ON_NOSUID_CHECK_OKAY
e688b231 3249 struct statfs stfs;
6439433f 3250
104d25b7 3251 check_okay = fstatfs(fd, &stfs) == 0;
104d25b7 3252 on_nosuid = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID);
ae3f3efd 3253 on_noexec = check_okay && (stfs.f_flags & PERL_MOUNT_NOEXEC);
6439433f
JH		 3254# endif /* fstatfs */
3255
3256# if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
3257 defined(PERL_MOUNT_NOSUID) && \
ae3f3efd 3258 defined(PERL_MOUNT_NOEXEC) && \
6439433f
JH		 3259 defined(HAS_FSTAT) && \
3260 defined(HAS_USTAT) && \
3261 defined(HAS_GETMNT) && \
3262 defined(HAS_STRUCT_FS_DATA) && \
3263 defined(NOSTAT_ONE)
3264# define FD_ON_NOSUID_CHECK_OKAY
c623ac67 3265 Stat_t fdst;
6439433f 3266
0545a864 3267 if (fstat(fd, &fdst) == 0) {
6439433f
JH		 3268 struct ustat us;
3269 if (ustat(fdst.st_dev, &us) == 0) {
3270 struct fs_data fsd;
3271 /* NOSTAT_ONE here because we're not examining fields which
3272 * vary between that case and STAT_ONE. */
ad27e871 3273 if (getmnt((int*)0, &fsd, (int)0, NOSTAT_ONE, us.f_fname) == 0) {
6439433f
JH		 3274 size_t cmplen = sizeof(us.f_fname);
3275 if (sizeof(fsd.fd_req.path) < cmplen)
3276 cmplen = sizeof(fsd.fd_req.path);
3277 if (strnEQ(fsd.fd_req.path, us.f_fname, cmplen) &&
3278 fdst.st_dev == fsd.fd_req.dev) {
3279 check_okay = 1;
3280 on_nosuid = fsd.fd_req.flags & PERL_MOUNT_NOSUID;
ae3f3efd 3281 on_noexec = fsd.fd_req.flags & PERL_MOUNT_NOEXEC;
6439433f
JH		 3282 }
3283 }
3284 }
3285 }
0545a864 3286 }
6439433f
JH		 3287# endif /* fstat+ustat+getmnt */
3288
3289# if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
3290 defined(HAS_GETMNTENT) && \
3291 defined(HAS_HASMNTOPT) && \
ae3f3efd
PS		 3292 defined(MNTOPT_NOSUID) && \
3293 defined(MNTOPT_NOEXEC)
6439433f
JH		 3294# define FD_ON_NOSUID_CHECK_OKAY
3295 FILE *mtab = fopen("/etc/mtab", "r");
3296 struct mntent *entry;
c623ac67 3297 Stat_t stb, fsb;
104d25b7
JH		 3298
3299 if (mtab && (fstat(fd, &stb) == 0)) {
6439433f
JH		 3300 while (entry = getmntent(mtab)) {
3301 if (stat(entry->mnt_dir, &fsb) == 0
3302 && fsb.st_dev == stb.st_dev)
3303 {
3304 /* found the filesystem */
3305 check_okay = 1;
3306 if (hasmntopt(entry, MNTOPT_NOSUID))
3307 on_nosuid = 1;
ae3f3efd
PS		 3308 if (hasmntopt(entry, MNTOPT_NOEXEC))
3309 on_noexec = 1;
6439433f
JH		 3310 break;
3311 } /* A single fs may well fail its stat(). */
3312 }
104d25b7
JH		 3313 }
3314 if (mtab)
6439433f
JH		 3315 fclose(mtab);
3316# endif /* getmntent+hasmntopt */
0545a864 3317
ac27b0f5 3318 if (!check_okay)
ae3f3efd
PS		 3319 Perl_croak(aTHX_ "Can't check filesystem of script \"%s\" for nosuid/noexec", PL_origfilename);
3320 if (on_nosuid)
3321 Perl_croak(aTHX_ "Setuid script \"%s\" on nosuid filesystem", PL_origfilename);
3322 if (on_noexec)
3323 Perl_croak(aTHX_ "Setuid script \"%s\" on noexec filesystem", PL_origfilename);
3324 return ((!check_okay) || on_nosuid || on_noexec);
104d25b7
JH		 3325}
3326#endif /* IAMSUID */
3327
76e3520e 3328STATIC void
e1ec3a88 3329S_validate_suid(pTHX_ const char *validarg, const char *scriptname)
79072805 3330{
155aba94 3331#ifdef IAMSUID
ae3f3efd
PS		 3332 /* int which; */
3333#endif /* IAMSUID */
96436eeb 3334
13281fa4
LW		 3335 /* do we need to emulate setuid on scripts? */
3336
3337 /* This code is for those BSD systems that have setuid #! scripts disabled
3338 * in the kernel because of a security problem. Merely defining DOSUID
3339 * in perl will not fix that problem, but if you have disabled setuid
3340 * scripts in the kernel, this will attempt to emulate setuid and setgid
3341 * on scripts that have those now-otherwise-useless bits set. The setuid
27e2fb84
LW		 3342 * root version must be called suidperl or sperlN.NNN. If regular perl
3343 * discovers that it has opened a setuid script, it calls suidperl with
3344 * the same argv that it had. If suidperl finds that the script it has
3345 * just opened is NOT setuid root, it sets the effective uid back to the
3346 * uid. We don't just make perl setuid root because that loses the
3347 * effective uid we had before invoking perl, if it was different from the
3348 * uid.
ae3f3efd
PS		 3349 * PSz 27 Feb 04
3350 * Description/comments above do not match current workings:
3351 * suidperl must be hardlinked to sperlN.NNN (that is what we exec);
3352 * suidperl called with script open and name changed to /dev/fd/N/X;
3353 * suidperl croaks if script is not setuid;
3354 * making perl setuid would be a huge security risk (and yes, that
3355 * would lose any euid we might have had).
13281fa4
LW		 3356 *
3357 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
3358 * be defined in suidperl only. suidperl must be setuid root. The
3359 * Configure script will set this up for you if you want it.
3360 */
a687059c 3361
13281fa4 3362#ifdef DOSUID
6e72f9df 3363 char *s, *s2;
a0d0e21e 3364
b28d0864 3365 if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0) /* normal stat is insecure */
cea2e8a9 3366 Perl_croak(aTHX_ "Can't stat script \"%s\"",PL_origfilename);
ae3f3efd 3367 if (PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
79072805 3368 I32 len;
2d8e6c8d 3369 STRLEN n_a;
13281fa4 3370
a687059c 3371#ifdef IAMSUID
ae3f3efd
PS		 3372 if (PL_fdscript < 0 || PL_suidscript != 1)
3373 Perl_croak(aTHX_ "Need (suid) fdscript in suidperl\n"); /* We already checked this */
3374 /* PSz 11 Nov 03
3375 * Since the script is opened by perl, not suidperl, some of these
3376 * checks are superfluous. Leaving them in probably does not lower
3377 * security(?!).
3378 */
3379 /* PSz 27 Feb 04
3380 * Do checks even for systems with no HAS_SETREUID.
3381 * We used to swap, then re-swap UIDs with
3382#ifdef HAS_SETREUID
3383 if (setreuid(PL_euid,PL_uid) < 0
3384 || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
3385 Perl_croak(aTHX_ "Can't swap uid and euid");
3386#endif
3387#ifdef HAS_SETREUID
3388 if (setreuid(PL_uid,PL_euid) < 0
3389 || PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid)
3390 Perl_croak(aTHX_ "Can't reswap uid and euid");
3391#endif
3392 */
3393
a687059c
LW		 3394 /* On this access check to make sure the directories are readable,
3395 * there is actually a small window that the user could use to make
3396 * filename point to an accessible directory. So there is a faint
3397 * chance that someone could execute a setuid script down in a
3398 * non-accessible directory. I don't know what to do about that.
3399 * But I don't think it's too important. The manual lies when
3400 * it says access() is useful in setuid programs.
ae3f3efd
PS		 3401 *
3402 * So, access() is pretty useless... but not harmful... do anyway.
a687059c 3403 */
e57400b1 3404 if (PerlLIO_access(CopFILE(PL_curcop),1)) { /*double check*/
ae3f3efd 3405 Perl_croak(aTHX_ "Can't access() script\n");
e57400b1 3406 }
ae3f3efd 3407
a687059c
LW		 3408 /* If we can swap euid and uid, then we can determine access rights
3409 * with a simple stat of the file, and then compare device and
3410 * inode to make sure we did stat() on the same file we opened.
3411 * Then we just have to make sure he or she can execute it.
ae3f3efd
PS		 3412 *
3413 * PSz 24 Feb 04
3414 * As the script is opened by perl, not suidperl, we do not need to
3415 * care much about access rights.
3416 *
3417 * The 'script changed' check is needed, or we can get lied to
3418 * about $0 with e.g.
3419 * suidperl /dev/fd/4//bin/x 4<setuidscript
3420 * Without HAS_SETREUID, is it safe to stat() as root?
3421 *
3422 * Are there any operating systems that pass /dev/fd/xxx for setuid
3423 * scripts, as suggested/described in perlsec(1)? Surely they do not
3424 * pass the script name as we do, so the "script changed" test would
3425 * fail for them... but we never get here with
3426 * SETUID_SCRIPTS_ARE_SECURE_NOW defined.
3427 *
3428 * This is one place where we must "lie" about return status: not
3429 * say if the stat() failed. We are doing this as root, and could
3430 * be tricked into reporting existence or not of files that the
3431 * "plain" user cannot even see.
a687059c
LW		 3432 */
3433 {
c623ac67 3434 Stat_t tmpstatbuf;
ae3f3efd
PS		 3435 if (PerlLIO_stat(CopFILE(PL_curcop),&tmpstatbuf) < 0 ||
3436 tmpstatbuf.st_dev != PL_statbuf.st_dev ||
b28d0864 3437 tmpstatbuf.st_ino != PL_statbuf.st_ino) {
ae3f3efd 3438 Perl_croak(aTHX_ "Setuid script changed\n");
a687059c 3439 }
ae3f3efd 3440
a687059c 3441 }
ae3f3efd
PS		 3442 if (!cando(S_IXUSR,FALSE,&PL_statbuf)) /* can real uid exec? */
3443 Perl_croak(aTHX_ "Real UID cannot exec script\n");
3444
3445 /* PSz 27 Feb 04
3446 * We used to do this check as the "plain" user (after swapping
3447 * UIDs). But the check for nosuid and noexec filesystem is needed,
3448 * and should be done even without HAS_SETREUID. (Maybe those
3449 * operating systems do not have such mount options anyway...)
3450 * Seems safe enough to do as root.
3451 */
3452#if !defined(NO_NOSUID_CHECK)
3453 if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp))) {
3454 Perl_croak(aTHX_ "Setuid script on nosuid or noexec filesystem\n");
3455 }
3456#endif
a687059c
LW		 3457#endif /* IAMSUID */
3458
e57400b1 3459 if (!S_ISREG(PL_statbuf.st_mode)) {
ae3f3efd 3460 Perl_croak(aTHX_ "Setuid script not plain file\n");
e57400b1 3461 }
b28d0864 3462 if (PL_statbuf.st_mode & S_IWOTH)
cea2e8a9 3463 Perl_croak(aTHX_ "Setuid/gid script is writable by world");
6b88bc9c 3464 PL_doswitches = FALSE; /* -s is insecure in suid */
ae3f3efd 3465 /* PSz 13 Nov 03 But -s was caught elsewhere ... so unsetting it here is useless(?!) */
57843af0 3466 CopLINE_inc(PL_curcop);
6b88bc9c 3467 if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch ||
2d8e6c8d 3468 strnNE(SvPV(PL_linestr,n_a),"#!",2) ) /* required even on Sys V */
cea2e8a9 3469 Perl_croak(aTHX_ "No #! line");
2d8e6c8d 3470 s = SvPV(PL_linestr,n_a)+2;
ae3f3efd
PS		 3471 /* PSz 27 Feb 04 */
3472 /* Sanity check on line length */
3473 if (strlen(s) < 1 || strlen(s) > 4000)
3474 Perl_croak(aTHX_ "Very long #! line");
3475 /* Allow more than a single space after #! */
3476 while (isSPACE(*s)) s++;
3477 /* Sanity check on buffer end */
3478 while ((*s) && !isSPACE(*s)) s++;
2d8e6c8d 3479 for (s2 = s; (s2 > SvPV(PL_linestr,n_a)+2 &&
3792a11b
NC		 3480 (isDIGIT(s2[-1]) || s2[-1] == '.' || s2[-1] == '_'
3481 || s2[-1] == '-')); s2--) ;
ae3f3efd
PS		 3482 /* Sanity check on buffer start */
3483 if ( (s2-4 < SvPV(PL_linestr,n_a)+2 || strnNE(s2-4,"perl",4)) &&
3484 (s-9 < SvPV(PL_linestr,n_a)+2 || strnNE(s-9,"perl",4)) )
cea2e8a9 3485 Perl_croak(aTHX_ "Not a perl script");
a687059c 3486 while (*s == ' ' || *s == '\t') s++;
13281fa4
LW		 3487 /*
3488 * #! arg must be what we saw above. They can invoke it by
3489 * mentioning suidperl explicitly, but they may not add any strange
3490 * arguments beyond what #! says if they do invoke suidperl that way.
3491 */
ae3f3efd
PS		 3492 /*
3493 * The way validarg was set up, we rely on the kernel to start
3494 * scripts with argv[1] set to contain all #! line switches (the
3495 * whole line).
3496 */
3497 /*
3498 * Check that we got all the arguments listed in the #! line (not
3499 * just that there are no extraneous arguments). Might not matter
3500 * much, as switches from #! line seem to be acted upon (also), and
3501 * so may be checked and trapped in perl. But, security checks must
3502 * be done in suidperl and not deferred to perl. Note that suidperl
3503 * does not get around to parsing (and checking) the switches on
3504 * the #! line (but execs perl sooner).
3505 * Allow (require) a trailing newline (which may be of two
3506 * characters on some architectures?) (but no other trailing
3507 * whitespace).
3508 */
13281fa4
LW		 3509 len = strlen(validarg);
3510 if (strEQ(validarg," PHOOEY ") ||
ae3f3efd
PS		 3511 strnNE(s,validarg,len) || !isSPACE(s[len]) ||
3512 !(strlen(s) == len+1 || (strlen(s) == len+2 && isSPACE(s[len+1]))))
cea2e8a9 3513 Perl_croak(aTHX_ "Args must match #! line");
a687059c
LW		 3514
3515#ifndef IAMSUID
ae3f3efd
PS		 3516 if (PL_fdscript < 0 &&
3517 PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
b28d0864
NIS		 3518 PL_euid == PL_statbuf.st_uid)
3519 if (!PL_do_undump)
cea2e8a9 3520 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
11fb1898 3521FIX YOUR KERNEL, OR PUT A C WRAPPER AROUND THIS SCRIPT!\n");
a687059c 3522#endif /* IAMSUID */
13281fa4 3523
ae3f3efd
PS		 3524 if (PL_fdscript < 0 &&
3525 PL_euid) { /* oops, we're not the setuid root perl */
3526 /* PSz 18 Feb 04
3527 * When root runs a setuid script, we do not go through the same
3528 * steps of execing sperl and then perl with fd scripts, but
3529 * simply set up UIDs within the same perl invocation; so do
3530 * not have the same checks (on options, whatever) that we have
3531 * for plain users. No problem really: would have to be a script
3532 * that does not actually work for plain users; and if root is
3533 * foolish and can be persuaded to run such an unsafe script, he
3534 * might run also non-setuid ones, and deserves what he gets.
3535 *
3536 * Or, we might drop the PL_euid check above (and rely just on
3537 * PL_fdscript to avoid loops), and do the execs
3538 * even for root.
3539 */
13281fa4 3540#ifndef IAMSUID
ae3f3efd
PS		 3541 int which;
3542 /* PSz 11 Nov 03
3543 * Pass fd script to suidperl.
3544 * Exec suidperl, substituting fd script for scriptname.
3545 * Pass script name as "subdir" of fd, which perl will grok;
3546 * in fact will use that to distinguish this from "normal"
3547 * usage, see comments above.
3548 */
3549 PerlIO_rewind(PL_rsfp);
3550 PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0); /* just in case rewind didn't */
3551 /* PSz 27 Feb 04 Sanity checks on scriptname */
3552 if ((!scriptname) || (!*scriptname) ) {
3553 Perl_croak(aTHX_ "No setuid script name\n");
3554 }
3555 if (*scriptname == '-') {
3556 Perl_croak(aTHX_ "Setuid script name may not begin with dash\n");
3557 /* Or we might confuse it with an option when replacing
3558 * name in argument list, below (though we do pointer, not
3559 * string, comparisons).
3560 */
3561 }
3562 for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;
3563 if (!PL_origargv[which]) {
3564 Perl_croak(aTHX_ "Can't change argv to have fd script\n");
3565 }
3566 PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s",
3567 PerlIO_fileno(PL_rsfp), PL_origargv[which]));