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