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