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