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