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