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
minor tweaks in Porting/pumpkin.pod
[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
5311654c
JH		 29#ifdef __BEOS__
30# define HZ 1000000
31#endif
32
33#ifndef HZ
34# ifdef CLK_TCK
35# define HZ CLK_TCK
36# else
37# define HZ 60
38# endif
39#endif
40
7114a2d2 41#if !defined(STANDARD_C) && !defined(HAS_GETENV_PROTOTYPE) && !defined(PERL_MICRO)
20ce7b12 42char *getenv (char *); /* Usually in <stdlib.h> */
54310121 43#endif
44
acfe0abc 45static I32 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen);
0cb96387 46
a687059c
LW		 47#ifdef IAMSUID
48#ifndef DOSUID
49#define DOSUID
50#endif
51#endif
378cc40b 52
a687059c
LW		 53#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
54#ifdef DOSUID
55#undef DOSUID
56#endif
57#endif
8d063cd8 58
4d1ff10f 59#if defined(USE_5005THREADS)
06d86050
GS		 60# define INIT_TLS_AND_INTERP \
61 STMT_START { \
62 if (!PL_curinterp) { \
63 PERL_SET_INTERP(my_perl); \
64 INIT_THREADS; \
65 ALLOC_THREAD_KEY; \
66 } \
67 } STMT_END
68#else
69# if defined(USE_ITHREADS)
70# define INIT_TLS_AND_INTERP \
71 STMT_START { \
72 if (!PL_curinterp) { \
73 PERL_SET_INTERP(my_perl); \
74 INIT_THREADS; \
75 ALLOC_THREAD_KEY; \
534825c4
GS		 76 PERL_SET_THX(my_perl); \
77 OP_REFCNT_INIT; \
78 } \
79 else { \
80 PERL_SET_THX(my_perl); \
06d86050 81 } \
06d86050
GS		 82 } STMT_END
83# else
84# define INIT_TLS_AND_INTERP \
85 STMT_START { \
86 if (!PL_curinterp) { \
87 PERL_SET_INTERP(my_perl); \
88 } \
89 PERL_SET_THX(my_perl); \
90 } STMT_END
91# endif
92#endif
93
32e30700
GS		 94#ifdef PERL_IMPLICIT_SYS
95PerlInterpreter *
7766f137
GS		 96perl_alloc_using(struct IPerlMem* ipM, struct IPerlMem* ipMS,
97 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
32e30700
GS		 98 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
99 struct IPerlDir* ipD, struct IPerlSock* ipS,
100 struct IPerlProc* ipP)
101{
102 PerlInterpreter *my_perl;
32e30700
GS		 103 /* New() needs interpreter, so call malloc() instead */
104 my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
06d86050 105 INIT_TLS_AND_INTERP;
32e30700
GS		 106 Zero(my_perl, 1, PerlInterpreter);
107 PL_Mem = ipM;
7766f137
GS		 108 PL_MemShared = ipMS;
109 PL_MemParse = ipMP;
32e30700
GS		 110 PL_Env = ipE;
111 PL_StdIO = ipStd;
112 PL_LIO = ipLIO;
113 PL_Dir = ipD;
114 PL_Sock = ipS;
115 PL_Proc = ipP;
7766f137 116
32e30700
GS		 117 return my_perl;
118}
119#else
954c1994
GS		 120
121/*
ccfc67b7
JH		 122=head1 Embedding Functions
123
954c1994
GS		 124=for apidoc perl_alloc
125
126Allocates a new Perl interpreter. See L<perlembed>.
127
128=cut
129*/
130
93a17b20 131PerlInterpreter *
cea2e8a9 132perl_alloc(void)
79072805 133{
cea2e8a9 134 PerlInterpreter *my_perl;
35d7cf2c
JH		 135#ifdef USE_5005THREADS
136 dTHX;
137#endif
79072805 138
54aff467 139 /* New() needs interpreter, so call malloc() instead */
e8ee3774 140 my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
ba869deb 141
06d86050 142 INIT_TLS_AND_INTERP;
dedcbb81 143 Zero(my_perl, 1, PerlInterpreter);
cea2e8a9 144 return my_perl;
79072805 145}
32e30700 146#endif /* PERL_IMPLICIT_SYS */
79072805 147
954c1994
GS		 148/*
149=for apidoc perl_construct
150
151Initializes a new Perl interpreter. See L<perlembed>.
152
153=cut
154*/
155
79072805 156void
0cb96387 157perl_construct(pTHXx)
79072805 158{
4d1ff10f 159#ifdef USE_5005THREADS
a863c7d1 160#ifndef FAKE_THREADS
e1f15930 161 struct perl_thread *thr = NULL;
a863c7d1 162#endif /* FAKE_THREADS */
4d1ff10f 163#endif /* USE_5005THREADS */
ba869deb 164
8990e307 165#ifdef MULTIPLICITY
54aff467 166 init_interp();
ac27b0f5 167 PL_perl_destruct_level = 1;
54aff467
GS		 168#else
169 if (PL_perl_destruct_level > 0)
170 init_interp();
171#endif
172
33f46ff6 173 /* Init the real globals (and main thread)? */
3280af22 174 if (!PL_linestr) {
4d1ff10f 175#ifdef USE_5005THREADS
533c011a 176 MUTEX_INIT(&PL_sv_mutex);
a863c7d1
MB		 177 /*
178 * Safe to use basic SV functions from now on (though
179 * not things like mortals or tainting yet).
180 */
533c011a
NIS		 181 MUTEX_INIT(&PL_eval_mutex);
182 COND_INIT(&PL_eval_cond);
183 MUTEX_INIT(&PL_threads_mutex);
184 COND_INIT(&PL_nthreads_cond);
ba869deb 185# ifdef EMULATE_ATOMIC_REFCOUNTS
533c011a 186 MUTEX_INIT(&PL_svref_mutex);
ba869deb 187# endif /* EMULATE_ATOMIC_REFCOUNTS */
a863c7d1 188
5ff3f7a4 189 MUTEX_INIT(&PL_cred_mutex);
3d35f11b
GS		 190 MUTEX_INIT(&PL_sv_lock_mutex);
191 MUTEX_INIT(&PL_fdpid_mutex);
5ff3f7a4 192
199100c8 193 thr = init_main_thread();
4d1ff10f 194#endif /* USE_5005THREADS */
11343788 195
14dd3ad8 196#ifdef PERL_FLEXIBLE_EXCEPTIONS
0b94c7bb 197 PL_protect = MEMBER_TO_FPTR(Perl_default_protect); /* for exceptions */
14dd3ad8 198#endif
312caa8e 199
2aea9f8a
GS		 200 PL_curcop = &PL_compiling; /* needed by ckWARN, right away */
201
3280af22
NIS		 202 PL_linestr = NEWSV(65,79);
203 sv_upgrade(PL_linestr,SVt_PVIV);
79072805 204
3280af22 205 if (!SvREADONLY(&PL_sv_undef)) {
d689ffdd
JP		 206 /* set read-only and try to insure than we wont see REFCNT==0
207 very often */
208
3280af22
NIS		 209 SvREADONLY_on(&PL_sv_undef);
210 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
79072805 211
3280af22
NIS		 212 sv_setpv(&PL_sv_no,PL_No);
213 SvNV(&PL_sv_no);
214 SvREADONLY_on(&PL_sv_no);
215 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
79072805 216
3280af22
NIS		 217 sv_setpv(&PL_sv_yes,PL_Yes);
218 SvNV(&PL_sv_yes);
219 SvREADONLY_on(&PL_sv_yes);
220 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
6e72f9df 221 }
79072805 222
cea2e8a9 223 PL_sighandlerp = Perl_sighandler;
3280af22 224 PL_pidstatus = newHV();
79072805
LW		 225 }
226
8bfdd7d9 227 PL_rs = newSVpvn("\n", 1);
dc92893f 228
cea2e8a9 229 init_stacks();
79072805 230
748a9306 231 init_ids();
3280af22 232 PL_lex_state = LEX_NOTPARSING;
a5f75d66 233
312caa8e 234 JMPENV_BOOTSTRAP;
f86702cc 235 STATUS_ALL_SUCCESS;
236
0672f40e 237 init_i18nl10n(1);
36477c24 238 SET_NUMERIC_STANDARD();
0b5b802d 239
a7cb1f99
GS		 240 {
241 U8 *s;
242 PL_patchlevel = NEWSV(0,4);
155aba94 243 (void)SvUPGRADE(PL_patchlevel, SVt_PVNV);
a7cb1f99 244 if (PERL_REVISION > 127 || PERL_VERSION > 127 || PERL_SUBVERSION > 127)
806e7201 245 SvGROW(PL_patchlevel, UTF8_MAXLEN*3+1);
a7cb1f99 246 s = (U8*)SvPVX(PL_patchlevel);
9041c2e3
NIS		 247 /* Build version strings using "native" characters */
248 s = uvchr_to_utf8(s, (UV)PERL_REVISION);
249 s = uvchr_to_utf8(s, (UV)PERL_VERSION);
250 s = uvchr_to_utf8(s, (UV)PERL_SUBVERSION);
a7cb1f99
GS		 251 *s = '\0';
252 SvCUR_set(PL_patchlevel, s - (U8*)SvPVX(PL_patchlevel));
253 SvPOK_on(PL_patchlevel);
254 SvNVX(PL_patchlevel) = (NV)PERL_REVISION
255 + ((NV)PERL_VERSION / (NV)1000)
cceca5ed 256#if defined(PERL_SUBVERSION) && PERL_SUBVERSION > 0
a7cb1f99 257 + ((NV)PERL_SUBVERSION / (NV)1000000)
a5f75d66 258#endif
a7cb1f99
GS		 259 ;
260 SvNOK_on(PL_patchlevel); /* dual valued */
261 SvUTF8_on(PL_patchlevel);
262 SvREADONLY_on(PL_patchlevel);
263 }
79072805 264
ab821d7f 265#if defined(LOCAL_PATCH_COUNT)
3280af22 266 PL_localpatches = local_patches; /* For possible -v */
ab821d7f 267#endif
268
52853b95
GS		 269#ifdef HAVE_INTERP_INTERN
270 sys_intern_init();
271#endif
272
3a1ee7e8 273 PerlIO_init(aTHX); /* Hook to IO system */
760ac839 274
3280af22
NIS		 275 PL_fdpid = newAV(); /* for remembering popen pids by fd */
276 PL_modglobal = newHV(); /* pointers to per-interpreter module globals */
24944567 277 PL_errors = newSVpvn("",0);
48c6b404 278 sv_setpvn(PERL_DEBUG_PAD(0), "", 0); /* For regex debugging. */
1f483ca1
JH		 279 sv_setpvn(PERL_DEBUG_PAD(1), "", 0); /* ext/re needs these */
280 sv_setpvn(PERL_DEBUG_PAD(2), "", 0); /* even without DEBUGGING. */
1fcf4c12 281#ifdef USE_ITHREADS
13137afc
AB		 282 PL_regex_padav = newAV();
283 av_push(PL_regex_padav,(SV*)newAV()); /* First entry is an array of empty elements */
284 PL_regex_pad = AvARRAY(PL_regex_padav);
1fcf4c12 285#endif
e5dd39fc 286#ifdef USE_REENTRANT_API
59bd0823 287 Perl_reentrant_init(aTHX);
e5dd39fc 288#endif
3d47000e
AB		 289
290 /* Note that strtab is a rather special HV. Assumptions are made
291 about not iterating on it, and not adding tie magic to it.
292 It is properly deallocated in perl_destruct() */
293 PL_strtab = newHV();
294
295#ifdef USE_5005THREADS
296 MUTEX_INIT(&PL_strtab_mutex);
297#endif
298 HvSHAREKEYS_off(PL_strtab); /* mandatory */
299 hv_ksplit(PL_strtab, 512);
300
0631ea03
AB		 301#if defined(__DYNAMIC__) && (defined(NeXT) || defined(__NeXT__))
302 _dyld_lookup_and_bind
303 ("__environ", (unsigned long *) &environ_pointer, NULL);
304#endif /* environ */
305
306#ifdef USE_ENVIRON_ARRAY
307 PL_origenviron = environ;
308#endif
309
5311654c
JH		 310 /* Use sysconf(_SC_CLK_TCK) if available, if not
311 * available or if the sysconf() fails, use the HZ. */
312#if defined(HAS_SYSCONF) && defined(_SC_CLK_TCK)
313 PL_clocktick = sysconf(_SC_CLK_TCK);
314 if (PL_clocktick <= 0)
315#endif
316 PL_clocktick = HZ;
317
8990e307 318 ENTER;
79072805
LW		 319}
320
954c1994 321/*
62375a60
NIS		 322=for apidoc nothreadhook
323
324Stub that provides thread hook for perl_destruct when there are
325no threads.
326
327=cut
328*/
329
330int
4e9e3734 331Perl_nothreadhook(pTHX)
62375a60
NIS		 332{
333 return 0;
334}
335
336/*
954c1994
GS		 337=for apidoc perl_destruct
338
339Shuts down a Perl interpreter. See L<perlembed>.
340
341=cut
342*/
343
31d77e54 344int
0cb96387 345perl_destruct(pTHXx)
79072805 346{
7c474504 347 volatile int destruct_level; /* 0=none, 1=full, 2=full with checks */
a0d0e21e 348 HV *hv;
4d1ff10f 349#ifdef USE_5005THREADS
33f46ff6 350 Thread t;
cea2e8a9 351 dTHX;
4d1ff10f 352#endif /* USE_5005THREADS */
8990e307 353
7766f137
GS		 354 /* wait for all pseudo-forked children to finish */
355 PERL_WAIT_FOR_CHILDREN;
356
4d1ff10f 357#ifdef USE_5005THREADS
0f15f207 358#ifndef FAKE_THREADS
8023c3ce
MB		 359 /* Pass 1 on any remaining threads: detach joinables, join zombies */
360 retry_cleanup:
533c011a 361 MUTEX_LOCK(&PL_threads_mutex);
bf49b057 362 DEBUG_S(PerlIO_printf(Perl_debug_log,
c7848ba1 363 "perl_destruct: waiting for %d threads...\n",
533c011a 364 PL_nthreads - 1));
33f46ff6 365 for (t = thr->next; t != thr; t = t->next) {
605e5515
MB		 366 MUTEX_LOCK(&t->mutex);
367 switch (ThrSTATE(t)) {
368 AV *av;
c7848ba1 369 case THRf_ZOMBIE:
bf49b057 370 DEBUG_S(PerlIO_printf(Perl_debug_log,
c7848ba1 371 "perl_destruct: joining zombie %p\n", t));
605e5515
MB		 372 ThrSETSTATE(t, THRf_DEAD);
373 MUTEX_UNLOCK(&t->mutex);
533c011a 374 PL_nthreads--;
8023c3ce
MB		 375 /*
376 * The SvREFCNT_dec below may take a long time (e.g. av
377 * may contain an object scalar whose destructor gets
378 * called) so we have to unlock threads_mutex and start
379 * all over again.
380 */
533c011a 381 MUTEX_UNLOCK(&PL_threads_mutex);
ea0efc06 382 JOIN(t, &av);
605e5515 383 SvREFCNT_dec((SV*)av);
bf49b057 384 DEBUG_S(PerlIO_printf(Perl_debug_log,
c7848ba1 385 "perl_destruct: joined zombie %p OK\n", t));
8023c3ce 386 goto retry_cleanup;
c7848ba1 387 case THRf_R_JOINABLE:
bf49b057 388 DEBUG_S(PerlIO_printf(Perl_debug_log,
c7848ba1
MB		 389 "perl_destruct: detaching thread %p\n", t));
390 ThrSETSTATE(t, THRf_R_DETACHED);
ac27b0f5 391 /*
c7848ba1
MB		 392 * We unlock threads_mutex and t->mutex in the opposite order
393 * from which we locked them just so that DETACH won't
394 * deadlock if it panics. It's only a breach of good style
395 * not a bug since they are unlocks not locks.
396 */
533c011a 397 MUTEX_UNLOCK(&PL_threads_mutex);
c7848ba1
MB		 398 DETACH(t);
399 MUTEX_UNLOCK(&t->mutex);
8023c3ce 400 goto retry_cleanup;
c7848ba1 401 default:
bf49b057 402 DEBUG_S(PerlIO_printf(Perl_debug_log,
c7848ba1
MB		 403 "perl_destruct: ignoring %p (state %u)\n",
404 t, ThrSTATE(t)));
405 MUTEX_UNLOCK(&t->mutex);
c7848ba1 406 /* fall through and out */
33f46ff6
MB		 407 }
408 }
8023c3ce
MB		 409 /* We leave the above "Pass 1" loop with threads_mutex still locked */
410
411 /* Pass 2 on remaining threads: wait for the thread count to drop to one */
533c011a 412 while (PL_nthreads > 1)
11343788 413 {
bf49b057 414 DEBUG_S(PerlIO_printf(Perl_debug_log,
c7848ba1 415 "perl_destruct: final wait for %d threads\n",
533c011a
NIS		 416 PL_nthreads - 1));
417 COND_WAIT(&PL_nthreads_cond, &PL_threads_mutex);
11343788
MB		 418 }
419 /* At this point, we're the last thread */
533c011a 420 MUTEX_UNLOCK(&PL_threads_mutex);
bf49b057 421 DEBUG_S(PerlIO_printf(Perl_debug_log, "perl_destruct: armageddon has arrived\n"));
533c011a
NIS		 422 MUTEX_DESTROY(&PL_threads_mutex);
423 COND_DESTROY(&PL_nthreads_cond);
b57a092c 424 PL_nthreads--;
0f15f207 425#endif /* !defined(FAKE_THREADS) */
4d1ff10f 426#endif /* USE_5005THREADS */
11343788 427
3280af22 428 destruct_level = PL_perl_destruct_level;
4633a7c4
LW		 429#ifdef DEBUGGING
430 {
431 char *s;
155aba94 432 if ((s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL"))) {
5f05dabc 433 int i = atoi(s);
434 if (destruct_level < i)
435 destruct_level = i;
436 }
4633a7c4
LW		 437 }
438#endif
439
31d77e54
AB		 440
441 if(PL_exit_flags & PERL_EXIT_DESTRUCT_END) {
f3faeb53
AB		 442 dJMPENV;
443 int x = 0;
444
445 JMPENV_PUSH(x);
446 if (PL_endav && !PL_minus_c)
447 call_list(PL_scopestack_ix, PL_endav);
448 JMPENV_POP;
26f423df 449 }
f3faeb53 450 LEAVE;
a0d0e21e
LW		 451 FREETMPS;
452
e00b64d4 453 /* Need to flush since END blocks can produce output */
f13a2bc0 454 my_fflush_all();
e00b64d4 455
62375a60
NIS		 456 if (CALL_FPTR(PL_threadhook)(aTHX)) {
457 /* Threads hook has vetoed further cleanup */
b47cad08 458 return STATUS_NATIVE_EXPORT;
62375a60
NIS		 459 }
460
ff0cee69 461 /* We must account for everything. */
462
463 /* Destroy the main CV and syntax tree */
3280af22 464 if (PL_main_root) {
dd2155a4 465 PAD_UPDATE_CURPAD;
3280af22
NIS		 466 op_free(PL_main_root);
467 PL_main_root = Nullop;
a0d0e21e 468 }
3280af22
NIS		 469 PL_curcop = &PL_compiling;
470 PL_main_start = Nullop;
471 SvREFCNT_dec(PL_main_cv);
472 PL_main_cv = Nullcv;
24d3c518 473 PL_dirty = TRUE;
ff0cee69 474
13621cfb
NIS		 475 /* Tell PerlIO we are about to tear things apart in case
476 we have layers which are using resources that should
477 be cleaned up now.
478 */
479
480 PerlIO_destruct(aTHX);
481
3280af22 482 if (PL_sv_objcount) {
a0d0e21e
LW		 483 /*
484 * Try to destruct global references. We do this first so that the
485 * destructors and destructees still exist. Some sv's might remain.
486 * Non-referenced objects are on their own.
487 */
a0d0e21e 488 sv_clean_objs();
8990e307
LW		 489 }
490
5cd24f17 491 /* unhook hooks which will soon be, or use, destroyed data */
3280af22
NIS		 492 SvREFCNT_dec(PL_warnhook);
493 PL_warnhook = Nullsv;
494 SvREFCNT_dec(PL_diehook);
495 PL_diehook = Nullsv;
5cd24f17 496
4b556e6c 497 /* call exit list functions */
3280af22 498 while (PL_exitlistlen-- > 0)
acfe0abc 499 PL_exitlist[PL_exitlistlen].fn(aTHX_ PL_exitlist[PL_exitlistlen].ptr);
4b556e6c 500
3280af22 501 Safefree(PL_exitlist);
4b556e6c 502
a0d0e21e 503 if (destruct_level == 0){
8990e307 504
a0d0e21e 505 DEBUG_P(debprofdump());
ac27b0f5 506
56a2bab7
NIS		 507#if defined(PERLIO_LAYERS)
508 /* No more IO - including error messages ! */
509 PerlIO_cleanup(aTHX);
510#endif
511
a0d0e21e 512 /* The exit() function will do everything that needs doing. */
b47cad08 513 return STATUS_NATIVE_EXPORT;
a0d0e21e 514 }
5dd60ef7 515
551a8b83 516 /* jettison our possibly duplicated environment */
4b647fb0
DM		 517 /* if PERL_USE_SAFE_PUTENV is defined environ will not have been copied
518 * so we certainly shouldn't free it here
519 */
520#if defined(USE_ENVIRON_ARRAY) && !defined(PERL_USE_SAFE_PUTENV)
4efc5df6
GS		 521 if (environ != PL_origenviron
522#ifdef USE_ITHREADS
523 /* only main thread can free environ[0] contents */
524 && PL_curinterp == aTHX
525#endif
526 )
527 {
551a8b83
JH		 528 I32 i;
529
530 for (i = 0; environ[i]; i++)
4b420006 531 safesysfree(environ[i]);
0631ea03 532
4b420006
JH		 533 /* Must use safesysfree() when working with environ. */
534 safesysfree(environ);
551a8b83
JH		 535
536 environ = PL_origenviron;
537 }
538#endif
539
5f8cb046
DM		 540#ifdef USE_ITHREADS
541 /* the syntax tree is shared between clones
542 * so op_free(PL_main_root) only ReREFCNT_dec's
543 * REGEXPs in the parent interpreter
544 * we need to manually ReREFCNT_dec for the clones
545 */
546 {
547 I32 i = AvFILLp(PL_regex_padav) + 1;
548 SV **ary = AvARRAY(PL_regex_padav);
549
550 while (i) {
35061a7e 551 SV *resv = ary[--i];
ba89bb6e 552 REGEXP *re = INT2PTR(REGEXP *,SvIVX(resv));
35061a7e
DM		 553
554 if (SvFLAGS(resv) & SVf_BREAK) {
577e12cc 555 /* this is PL_reg_curpm, already freed
35061a7e
DM		 556 * flag is set in regexec.c:S_regtry
557 */
558 SvFLAGS(resv) &= ~SVf_BREAK;
3a1ee7e8 559 }
1cc8b4c5
AB		 560 else if(SvREPADTMP(resv)) {
561 SvREPADTMP_off(resv);
562 }
35061a7e 563 else {
5f8cb046
DM		 564 ReREFCNT_dec(re);
565 }
566 }
567 }
568 SvREFCNT_dec(PL_regex_padav);
569 PL_regex_padav = Nullav;
570 PL_regex_pad = NULL;
571#endif
572
5f05dabc 573 /* loosen bonds of global variables */
574
3280af22
NIS		 575 if(PL_rsfp) {
576 (void)PerlIO_close(PL_rsfp);
577 PL_rsfp = Nullfp;
8ebc5c01 578 }
579
580 /* Filters for program text */
3280af22
NIS		 581 SvREFCNT_dec(PL_rsfp_filters);
582 PL_rsfp_filters = Nullav;
8ebc5c01 583
584 /* switches */
3280af22
NIS		 585 PL_preprocess = FALSE;
586 PL_minus_n = FALSE;
587 PL_minus_p = FALSE;
588 PL_minus_l = FALSE;
589 PL_minus_a = FALSE;
590 PL_minus_F = FALSE;
591 PL_doswitches = FALSE;
599cee73 592 PL_dowarn = G_WARN_OFF;
3280af22
NIS		 593 PL_doextract = FALSE;
594 PL_sawampersand = FALSE; /* must save all match strings */
3280af22
NIS		 595 PL_unsafe = FALSE;
596
597 Safefree(PL_inplace);
598 PL_inplace = Nullch;
a7cb1f99 599 SvREFCNT_dec(PL_patchlevel);
3280af22
NIS		 600
601 if (PL_e_script) {
602 SvREFCNT_dec(PL_e_script);
603 PL_e_script = Nullsv;
8ebc5c01 604 }
605
bc0a45ed
DM		 606 while (--PL_origargc >= 0) {
607 Safefree(PL_origargv[PL_origargc]);
608 }
609 Safefree(PL_origargv);
610
8ebc5c01 611 /* magical thingies */
612
7889fe52
NIS		 613 SvREFCNT_dec(PL_ofs_sv); /* $, */
614 PL_ofs_sv = Nullsv;
5f05dabc 615
7889fe52
NIS		 616 SvREFCNT_dec(PL_ors_sv); /* $\ */
617 PL_ors_sv = Nullsv;
8ebc5c01 618
3280af22
NIS		 619 SvREFCNT_dec(PL_rs); /* $/ */
620 PL_rs = Nullsv;
dc92893f 621
d33b2eba
GS		 622 PL_multiline = 0; /* $* */
623 Safefree(PL_osname); /* $^O */
624 PL_osname = Nullch;
5f05dabc 625
3280af22
NIS		 626 SvREFCNT_dec(PL_statname);
627 PL_statname = Nullsv;
628 PL_statgv = Nullgv;
5f05dabc 629
8ebc5c01 630 /* defgv, aka *_ should be taken care of elsewhere */
631
8ebc5c01 632 /* clean up after study() */
3280af22
NIS		 633 SvREFCNT_dec(PL_lastscream);
634 PL_lastscream = Nullsv;
635 Safefree(PL_screamfirst);
636 PL_screamfirst = 0;
637 Safefree(PL_screamnext);
638 PL_screamnext = 0;
8ebc5c01 639
7d5ea4e7
GS		 640 /* float buffer */
641 Safefree(PL_efloatbuf);
642 PL_efloatbuf = Nullch;
643 PL_efloatsize = 0;
644
8ebc5c01 645 /* startup and shutdown function lists */
3280af22 646 SvREFCNT_dec(PL_beginav);
5a837c8f 647 SvREFCNT_dec(PL_beginav_save);
3280af22 648 SvREFCNT_dec(PL_endav);
7d30b5c4 649 SvREFCNT_dec(PL_checkav);
ece599bd 650 SvREFCNT_dec(PL_checkav_save);
3280af22
NIS		 651 SvREFCNT_dec(PL_initav);
652 PL_beginav = Nullav;
5a837c8f 653 PL_beginav_save = Nullav;
3280af22 654 PL_endav = Nullav;
7d30b5c4 655 PL_checkav = Nullav;
ece599bd 656 PL_checkav_save = Nullav;
3280af22 657 PL_initav = Nullav;
5618dfe8 658
8ebc5c01 659 /* shortcuts just get cleared */
3280af22 660 PL_envgv = Nullgv;
3280af22
NIS		 661 PL_incgv = Nullgv;
662 PL_hintgv = Nullgv;
663 PL_errgv = Nullgv;
664 PL_argvgv = Nullgv;
665 PL_argvoutgv = Nullgv;
666 PL_stdingv = Nullgv;
bf49b057 667 PL_stderrgv = Nullgv;
3280af22
NIS		 668 PL_last_in_gv = Nullgv;
669 PL_replgv = Nullgv;
5c831c24 670 PL_debstash = Nullhv;
8ebc5c01 671
672 /* reset so print() ends up where we expect */
673 setdefout(Nullgv);
5c831c24 674
7a1c5554
GS		 675 SvREFCNT_dec(PL_argvout_stack);
676 PL_argvout_stack = Nullav;
8ebc5c01 677
5c831c24
GS		 678 SvREFCNT_dec(PL_modglobal);
679 PL_modglobal = Nullhv;
680 SvREFCNT_dec(PL_preambleav);
681 PL_preambleav = Nullav;
682 SvREFCNT_dec(PL_subname);
683 PL_subname = Nullsv;
684 SvREFCNT_dec(PL_linestr);
685 PL_linestr = Nullsv;
686 SvREFCNT_dec(PL_pidstatus);
687 PL_pidstatus = Nullhv;
688 SvREFCNT_dec(PL_toptarget);
689 PL_toptarget = Nullsv;
690 SvREFCNT_dec(PL_bodytarget);
691 PL_bodytarget = Nullsv;
692 PL_formtarget = Nullsv;
693
d33b2eba 694 /* free locale stuff */
b9582b6a 695#ifdef USE_LOCALE_COLLATE
d33b2eba
GS		 696 Safefree(PL_collation_name);
697 PL_collation_name = Nullch;
b9582b6a 698#endif
d33b2eba 699
b9582b6a 700#ifdef USE_LOCALE_NUMERIC
d33b2eba
GS		 701 Safefree(PL_numeric_name);
702 PL_numeric_name = Nullch;
a453c169 703 SvREFCNT_dec(PL_numeric_radix_sv);
b9582b6a 704#endif
d33b2eba 705
5c831c24
GS		 706 /* clear utf8 character classes */
707 SvREFCNT_dec(PL_utf8_alnum);
708 SvREFCNT_dec(PL_utf8_alnumc);
709 SvREFCNT_dec(PL_utf8_ascii);
710 SvREFCNT_dec(PL_utf8_alpha);
711 SvREFCNT_dec(PL_utf8_space);
712 SvREFCNT_dec(PL_utf8_cntrl);
713 SvREFCNT_dec(PL_utf8_graph);
714 SvREFCNT_dec(PL_utf8_digit);
715 SvREFCNT_dec(PL_utf8_upper);
716 SvREFCNT_dec(PL_utf8_lower);
717 SvREFCNT_dec(PL_utf8_print);
718 SvREFCNT_dec(PL_utf8_punct);
719 SvREFCNT_dec(PL_utf8_xdigit);
720 SvREFCNT_dec(PL_utf8_mark);
721 SvREFCNT_dec(PL_utf8_toupper);
4dbdbdc2 722 SvREFCNT_dec(PL_utf8_totitle);
5c831c24 723 SvREFCNT_dec(PL_utf8_tolower);
b4e400f9 724 SvREFCNT_dec(PL_utf8_tofold);
82686b01
JH		 725 SvREFCNT_dec(PL_utf8_idstart);
726 SvREFCNT_dec(PL_utf8_idcont);
5c831c24
GS		 727 PL_utf8_alnum = Nullsv;
728 PL_utf8_alnumc = Nullsv;
729 PL_utf8_ascii = Nullsv;
730 PL_utf8_alpha = Nullsv;
731 PL_utf8_space = Nullsv;
732 PL_utf8_cntrl = Nullsv;
733 PL_utf8_graph = Nullsv;
734 PL_utf8_digit = Nullsv;
735 PL_utf8_upper = Nullsv;
736 PL_utf8_lower = Nullsv;
737 PL_utf8_print = Nullsv;
738 PL_utf8_punct = Nullsv;
739 PL_utf8_xdigit = Nullsv;
740 PL_utf8_mark = Nullsv;
741 PL_utf8_toupper = Nullsv;
742 PL_utf8_totitle = Nullsv;
743 PL_utf8_tolower = Nullsv;
b4e400f9 744 PL_utf8_tofold = Nullsv;
82686b01
JH		 745 PL_utf8_idstart = Nullsv;
746 PL_utf8_idcont = Nullsv;
5c831c24 747
971a9dd3
GS		 748 if (!specialWARN(PL_compiling.cop_warnings))
749 SvREFCNT_dec(PL_compiling.cop_warnings);
5c831c24 750 PL_compiling.cop_warnings = Nullsv;
ac27b0f5
NIS		 751 if (!specialCopIO(PL_compiling.cop_io))
752 SvREFCNT_dec(PL_compiling.cop_io);
753 PL_compiling.cop_io = Nullsv;
05ec9bb3
NIS		 754 CopFILE_free(&PL_compiling);
755 CopSTASH_free(&PL_compiling);
5c831c24 756
a0d0e21e 757 /* Prepare to destruct main symbol table. */
5f05dabc 758
3280af22
NIS		 759 hv = PL_defstash;
760 PL_defstash = 0;
a0d0e21e 761 SvREFCNT_dec(hv);
5c831c24
GS		 762 SvREFCNT_dec(PL_curstname);
763 PL_curstname = Nullsv;
a0d0e21e 764
5a844595
GS		 765 /* clear queued errors */
766 SvREFCNT_dec(PL_errors);
767 PL_errors = Nullsv;
768
a0d0e21e 769 FREETMPS;
0453d815 770 if (destruct_level >= 2 && ckWARN_d(WARN_INTERNAL)) {
3280af22 771 if (PL_scopestack_ix != 0)
9014280d 772 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
0453d815 773 "Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
3280af22
NIS		 774 (long)PL_scopestack_ix);
775 if (PL_savestack_ix != 0)
9014280d 776 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
0453d815 777 "Unbalanced saves: %ld more saves than restores\n",
3280af22
NIS		 778 (long)PL_savestack_ix);
779 if (PL_tmps_floor != -1)
9014280d 780 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced tmps: %ld more allocs than frees\n",
3280af22 781 (long)PL_tmps_floor + 1);
a0d0e21e 782 if (cxstack_ix != -1)
9014280d 783 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced context: %ld more PUSHes than POPs\n",
ff0cee69 784 (long)cxstack_ix + 1);
a0d0e21e 785 }
8990e307
LW		 786
787 /* Now absolutely destruct everything, somehow or other, loops or no. */
d33b2eba 788 SvFLAGS(PL_fdpid) |= SVTYPEMASK; /* don't clean out pid table now */
3280af22 789 SvFLAGS(PL_strtab) |= SVTYPEMASK; /* don't clean out strtab now */
5226ed68
JH		 790
791 /* the 2 is for PL_fdpid and PL_strtab */
792 while (PL_sv_count > 2 && sv_clean_all())
793 ;
794
d33b2eba
GS		 795 SvFLAGS(PL_fdpid) &= ~SVTYPEMASK;
796 SvFLAGS(PL_fdpid) |= SVt_PVAV;
3280af22
NIS		 797 SvFLAGS(PL_strtab) &= ~SVTYPEMASK;
798 SvFLAGS(PL_strtab) |= SVt_PVHV;
d33b2eba 799
d4777f27
GS		 800 AvREAL_off(PL_fdpid); /* no surviving entries */
801 SvREFCNT_dec(PL_fdpid); /* needed in io_close() */
d33b2eba
GS		 802 PL_fdpid = Nullav;
803
6c644e78
GS		 804#ifdef HAVE_INTERP_INTERN
805 sys_intern_clear();
806#endif
807
6e72f9df 808 /* Destruct the global string table. */
809 {
810 /* Yell and reset the HeVAL() slots that are still holding refcounts,
811 * so that sv_free() won't fail on them.
812 */
813 I32 riter;
814 I32 max;
815 HE *hent;
816 HE **array;
817
818 riter = 0;
3280af22
NIS		 819 max = HvMAX(PL_strtab);
820 array = HvARRAY(PL_strtab);
6e72f9df 821 hent = array[0];
822 for (;;) {
0453d815 823 if (hent && ckWARN_d(WARN_INTERNAL)) {
9014280d 824 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
0453d815 825 "Unbalanced string table refcount: (%d) for \"%s\"",
6e72f9df 826 HeVAL(hent) - Nullsv, HeKEY(hent));
827 HeVAL(hent) = Nullsv;
828 hent = HeNEXT(hent);
829 }
830 if (!hent) {
831 if (++riter > max)
832 break;
833 hent = array[riter];
834 }
835 }
836 }
3280af22 837 SvREFCNT_dec(PL_strtab);
6e72f9df 838
e652bb2f 839#ifdef USE_ITHREADS
a0739874
DM		 840 /* free the pointer table used for cloning */
841 ptr_table_free(PL_ptr_table);
53186e96 842#endif
a0739874 843
d33b2eba
GS		 844 /* free special SVs */
845
846 SvREFCNT(&PL_sv_yes) = 0;
847 sv_clear(&PL_sv_yes);
848 SvANY(&PL_sv_yes) = NULL;
4c5e2b0d 849 SvFLAGS(&PL_sv_yes) = 0;
d33b2eba
GS		 850
851 SvREFCNT(&PL_sv_no) = 0;
852 sv_clear(&PL_sv_no);
853 SvANY(&PL_sv_no) = NULL;
4c5e2b0d 854 SvFLAGS(&PL_sv_no) = 0;
01724ea0 855
9f375a43
DM		 856 {
857 int i;
858 for (i=0; i<=2; i++) {
859 SvREFCNT(PERL_DEBUG_PAD(i)) = 0;
860 sv_clear(PERL_DEBUG_PAD(i));
861 SvANY(PERL_DEBUG_PAD(i)) = NULL;
862 SvFLAGS(PERL_DEBUG_PAD(i)) = 0;
863 }
864 }
865
0453d815 866 if (PL_sv_count != 0 && ckWARN_d(WARN_INTERNAL))
9014280d 867 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Scalars leaked: %ld\n", (long)PL_sv_count);
6e72f9df 868
56a2bab7 869#if defined(PERLIO_LAYERS)
3a1ee7e8
NIS		 870 /* No more IO - including error messages ! */
871 PerlIO_cleanup(aTHX);
872#endif
873
9f4bd222
NIS		 874 /* sv_undef needs to stay immortal until after PerlIO_cleanup
875 as currently layers use it rather than Nullsv as a marker
876 for no arg - and will try and SvREFCNT_dec it.
877 */
878 SvREFCNT(&PL_sv_undef) = 0;
879 SvREADONLY_off(&PL_sv_undef);
880
3280af22 881 Safefree(PL_origfilename);
3280af22 882 Safefree(PL_reg_start_tmp);
5c5e4c24
IZ		 883 if (PL_reg_curpm)
884 Safefree(PL_reg_curpm);
82ba1be6 885 Safefree(PL_reg_poscache);
3280af22
NIS		 886 Safefree(HeKEY_hek(&PL_hv_fetch_ent_mh));
887 Safefree(PL_op_mask);
cf36064f
GS		 888 Safefree(PL_psig_ptr);
889 Safefree(PL_psig_name);
2c2666fc 890 Safefree(PL_bitcount);
ce08f86c 891 Safefree(PL_psig_pend);
6e72f9df 892 nuke_stacks();
3280af22 893 PL_hints = 0; /* Reset hints. Should hints be per-interpreter ? */
ac27b0f5 894
a0d0e21e 895 DEBUG_P(debprofdump());
4d1ff10f 896#ifdef USE_5005THREADS
5f08fbcd 897 MUTEX_DESTROY(&PL_strtab_mutex);
533c011a
NIS		 898 MUTEX_DESTROY(&PL_sv_mutex);
899 MUTEX_DESTROY(&PL_eval_mutex);
5ff3f7a4 900 MUTEX_DESTROY(&PL_cred_mutex);
3d35f11b 901 MUTEX_DESTROY(&PL_fdpid_mutex);
533c011a 902 COND_DESTROY(&PL_eval_cond);
11d617a5
GS		 903#ifdef EMULATE_ATOMIC_REFCOUNTS
904 MUTEX_DESTROY(&PL_svref_mutex);
905#endif /* EMULATE_ATOMIC_REFCOUNTS */
fc36a67e 906
8023c3ce 907 /* As the penultimate thing, free the non-arena SV for thrsv */
533c011a
NIS		 908 Safefree(SvPVX(PL_thrsv));
909 Safefree(SvANY(PL_thrsv));
910 Safefree(PL_thrsv);
911 PL_thrsv = Nullsv;
4d1ff10f 912#endif /* USE_5005THREADS */
d33b2eba 913
e5dd39fc 914#ifdef USE_REENTRANT_API
10bc17b6 915 Perl_reentrant_free(aTHX);
e5dd39fc
AB		 916#endif
917
612f20c3
GS		 918 sv_free_arenas();
919
fc36a67e 920 /* As the absolutely last thing, free the non-arena SV for mess() */
921
3280af22 922 if (PL_mess_sv) {
9c63abab
GS		 923 /* it could have accumulated taint magic */
924 if (SvTYPE(PL_mess_sv) >= SVt_PVMG) {
925 MAGIC* mg;
926 MAGIC* moremagic;
927 for (mg = SvMAGIC(PL_mess_sv); mg; mg = moremagic) {
928 moremagic = mg->mg_moremagic;
14befaf4
DM		 929 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global
930 && mg->mg_len >= 0)
9c63abab
GS		 931 Safefree(mg->mg_ptr);
932 Safefree(mg);
933 }
934 }
fc36a67e 935 /* we know that type >= SVt_PV */
155aba94 936 (void)SvOOK_off(PL_mess_sv);
3280af22
NIS		 937 Safefree(SvPVX(PL_mess_sv));
938 Safefree(SvANY(PL_mess_sv));
939 Safefree(PL_mess_sv);
940 PL_mess_sv = Nullsv;
fc36a67e 941 }
31d77e54 942 return STATUS_NATIVE_EXPORT;
79072805
LW		 943}
944
954c1994
GS		 945/*
946=for apidoc perl_free
947
948Releases a Perl interpreter. See L<perlembed>.
949
950=cut
951*/
952
79072805 953void
0cb96387 954perl_free(pTHXx)
79072805 955{
acfe0abc 956#if defined(WIN32) || defined(NETWARE)
ce3e5b80 957# if defined(PERL_IMPLICIT_SYS)
acfe0abc
GS		 958# ifdef NETWARE
959 void *host = nw_internal_host;
960# else
961 void *host = w32_internal_host;
962# endif
ce3e5b80 963 PerlMem_free(aTHXx);
acfe0abc 964# ifdef NETWARE
011f1a1a 965 nw_delete_internal_host(host);
acfe0abc
GS		 966# else
967 win32_delete_internal_host(host);
968# endif
1c0ca838
GS		 969# else
970 PerlMem_free(aTHXx);
971# endif
acfe0abc
GS		 972#else
973 PerlMem_free(aTHXx);
76e3520e 974#endif
79072805
LW		 975}
976
4b556e6c 977void
864dbfa3 978Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr)
4b556e6c 979{
3280af22
NIS		 980 Renew(PL_exitlist, PL_exitlistlen+1, PerlExitListEntry);
981 PL_exitlist[PL_exitlistlen].fn = fn;
982 PL_exitlist[PL_exitlistlen].ptr = ptr;
983 ++PL_exitlistlen;
4b556e6c
JD		 984}
985
954c1994
GS		 986/*
987=for apidoc perl_parse
988
989Tells a Perl interpreter to parse a Perl script. See L<perlembed>.
990
991=cut
992*/
993
79072805 994int
0cb96387 995perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env)
8d063cd8 996{
6224f72b 997 I32 oldscope;
6224f72b 998 int ret;
db36c5a1 999 dJMPENV;
4d1ff10f 1000#ifdef USE_5005THREADS
cea2e8a9
GS		 1001 dTHX;
1002#endif
8d063cd8 1003
a687059c
LW		 1004#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
1005#ifdef IAMSUID
1006#undef IAMSUID
cea2e8a9 1007 Perl_croak(aTHX_ "suidperl is no longer needed since the kernel can now execute\n\
a687059c
LW		 1008setuid perl scripts securely.\n");
1009#endif
1010#endif
1011
3280af22 1012 PL_origargc = argc;
bc0a45ed
DM		 1013 {
1014 /* we copy rather than point to argv
1015 * since perl_clone will copy and perl_destruct
3a1ee7e8 1016 * has no way of knowing if we've made a copy or
bc0a45ed
DM		 1017 * just point to argv
1018 */
1019 int i = PL_origargc;
1020 New(0, PL_origargv, i+1, char*);
1021 PL_origargv[i] = '\0';
1022 while (i-- > 0) {
1023 PL_origargv[i] = savepv(argv[i]);
1024 }
1025 }
1026
0631ea03 1027
a0d0e21e 1028
3280af22 1029 if (PL_do_undump) {
a0d0e21e
LW		 1030
1031 /* Come here if running an undumped a.out. */
1032
3280af22
NIS		 1033 PL_origfilename = savepv(argv[0]);
1034 PL_do_undump = FALSE;
a0d0e21e 1035 cxstack_ix = -1; /* start label stack again */
748a9306 1036 init_ids();
a0d0e21e
LW		 1037 init_postdump_symbols(argc,argv,env);
1038 return 0;
1039 }
1040
3280af22 1041 if (PL_main_root) {
dd2155a4 1042 PAD_UPDATE_CURPAD;
3280af22
NIS		 1043 op_free(PL_main_root);
1044 PL_main_root = Nullop;
ff0cee69 1045 }
3280af22
NIS		 1046 PL_main_start = Nullop;
1047 SvREFCNT_dec(PL_main_cv);
1048 PL_main_cv = Nullcv;
79072805 1049
3280af22
NIS		 1050 time(&PL_basetime);
1051 oldscope = PL_scopestack_ix;
599cee73 1052 PL_dowarn = G_WARN_OFF;
f86702cc 1053
14dd3ad8
GS		 1054#ifdef PERL_FLEXIBLE_EXCEPTIONS
1055 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vparse_body), env, xsinit);
1056#else
1057 JMPENV_PUSH(ret);
1058#endif
6224f72b 1059 switch (ret) {
312caa8e 1060 case 0:
14dd3ad8
GS		 1061#ifndef PERL_FLEXIBLE_EXCEPTIONS
1062 parse_body(env,xsinit);
1063#endif
7d30b5c4
GS		 1064 if (PL_checkav)
1065 call_list(oldscope, PL_checkav);
14dd3ad8
GS		 1066 ret = 0;
1067 break;
6224f72b
GS		 1068 case 1:
1069 STATUS_ALL_FAILURE;
1070 /* FALL THROUGH */
1071 case 2:
1072 /* my_exit() was called */
3280af22 1073 while (PL_scopestack_ix > oldscope)
6224f72b
GS		 1074 LEAVE;
1075 FREETMPS;
3280af22 1076 PL_curstash = PL_defstash;
7d30b5c4
GS		 1077 if (PL_checkav)
1078 call_list(oldscope, PL_checkav);
14dd3ad8
GS		 1079 ret = STATUS_NATIVE_EXPORT;
1080 break;
6224f72b 1081 case 3:
bf49b057 1082 PerlIO_printf(Perl_error_log, "panic: top_env\n");
14dd3ad8
GS		 1083 ret = 1;
1084 break;
6224f72b 1085 }
14dd3ad8
GS		 1086 JMPENV_POP;
1087 return ret;
1088}
1089
1090#ifdef PERL_FLEXIBLE_EXCEPTIONS
1091STATIC void *
1092S_vparse_body(pTHX_ va_list args)
1093{
1094 char **env = va_arg(args, char**);
1095 XSINIT_t xsinit = va_arg(args, XSINIT_t);
1096
1097 return parse_body(env, xsinit);
312caa8e 1098}
14dd3ad8 1099#endif
312caa8e
CS		 1100
1101STATIC void *
14dd3ad8 1102S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
312caa8e 1103{
312caa8e
CS		 1104 int argc = PL_origargc;
1105 char **argv = PL_origargv;
312caa8e
CS		 1106 char *scriptname = NULL;
1107 int fdscript = -1;
1108 VOL bool dosearch = FALSE;
1109 char *validarg = "";
312caa8e
CS		 1110 register SV *sv;
1111 register char *s;
cf756827 1112 char *cddir = Nullch;
312caa8e 1113
3280af22 1114 sv_setpvn(PL_linestr,"",0);
79cb57f6 1115 sv = newSVpvn("",0); /* first used for -I flags */
6224f72b
GS		 1116 SAVEFREESV(sv);
1117 init_main_stash();
54310121 1118
6224f72b
GS		 1119 for (argc--,argv++; argc > 0; argc--,argv++) {
1120 if (argv[0][0] != '-' || !argv[0][1])
1121 break;
1122#ifdef DOSUID
1123 if (*validarg)
1124 validarg = " PHOOEY ";
1125 else
1126 validarg = argv[0];
13281fa4 1127#endif
6224f72b
GS		 1128 s = argv[0]+1;
1129 reswitch:
1130 switch (*s) {
729a02f2
GS		 1131 case 'C':
1132#ifdef WIN32
c0932edc 1133 win32_argv2utf8(argc-1, argv+1);
729a02f2
GS		 1134 /* FALL THROUGH */
1135#endif
1d5472a9
GS		 1136#ifndef PERL_STRICT_CR
1137 case '\r':
1138#endif
6224f72b
GS		 1139 case ' ':
1140 case '0':
1141 case 'F':
1142 case 'a':
1143 case 'c':
1144 case 'd':
1145 case 'D':
1146 case 'h':
1147 case 'i':
1148 case 'l':
1149 case 'M':
1150 case 'm':
1151 case 'n':
1152 case 'p':
1153 case 's':
1154 case 'u':
1155 case 'U':
1156 case 'v':
599cee73
PM		 1157 case 'W':
1158 case 'X':
6224f72b 1159 case 'w':
155aba94 1160 if ((s = moreswitches(s)))
6224f72b
GS		 1161 goto reswitch;
1162 break;
33b78306 1163
1dbad523 1164 case 't':
317ea90d
MS		 1165 if( !PL_tainting ) {
1166 PL_taint_warn = TRUE;
1167 PL_tainting = TRUE;
1168 }
1169 s++;
1170 goto reswitch;
6224f72b 1171 case 'T':
3280af22 1172 PL_tainting = TRUE;
317ea90d 1173 PL_taint_warn = FALSE;
6224f72b
GS		 1174 s++;
1175 goto reswitch;
f86702cc 1176
6224f72b 1177 case 'e':
bf4acbe4
GS		 1178#ifdef MACOS_TRADITIONAL
1179 /* ignore -e for Dev:Pseudo argument */
1180 if (argv[1] && !strcmp(argv[1], "Dev:Pseudo"))
e55ac0fa 1181 break;
bf4acbe4 1182#endif
3280af22 1183 if (PL_euid != PL_uid || PL_egid != PL_gid)
cea2e8a9 1184 Perl_croak(aTHX_ "No -e allowed in setuid scripts");
3280af22 1185 if (!PL_e_script) {
79cb57f6 1186 PL_e_script = newSVpvn("",0);
0cb96387 1187 filter_add(read_e_script, NULL);
6224f72b
GS		 1188 }
1189 if (*++s)
3280af22 1190 sv_catpv(PL_e_script, s);
6224f72b 1191 else if (argv[1]) {
3280af22 1192 sv_catpv(PL_e_script, argv[1]);
6224f72b
GS		 1193 argc--,argv++;
1194 }
1195 else
cea2e8a9 1196 Perl_croak(aTHX_ "No code specified for -e");
3280af22 1197 sv_catpv(PL_e_script, "\n");
6224f72b 1198 break;
afe37c7d 1199
6224f72b
GS		 1200 case 'I': /* -I handled both here and in moreswitches() */
1201 forbid_setid("-I");
1202 if (!*++s && (s=argv[1]) != Nullch) {
1203 argc--,argv++;
1204 }
6224f72b 1205 if (s && *s) {
0df16ed7
GS		 1206 char *p;
1207 STRLEN len = strlen(s);
1208 p = savepvn(s, len);
9c8a64f0 1209 incpush(p, TRUE, TRUE);
0df16ed7
GS		 1210 sv_catpvn(sv, "-I", 2);
1211 sv_catpvn(sv, p, len);
1212 sv_catpvn(sv, " ", 1);
6224f72b 1213 Safefree(p);
0df16ed7
GS		 1214 }
1215 else
a67e862a 1216 Perl_croak(aTHX_ "No directory specified for -I");
6224f72b
GS		 1217 break;
1218 case 'P':
1219 forbid_setid("-P");
3280af22 1220 PL_preprocess = TRUE;
6224f72b
GS		 1221 s++;
1222 goto reswitch;
1223 case 'S':
1224 forbid_setid("-S");
1225 dosearch = TRUE;
1226 s++;
1227 goto reswitch;
1228 case 'V':
3280af22
NIS		 1229 if (!PL_preambleav)
1230 PL_preambleav = newAV();
1231 av_push(PL_preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
6224f72b 1232 if (*++s != ':') {
3280af22 1233 PL_Sv = newSVpv("print myconfig();",0);
6224f72b 1234#ifdef VMS
6b88bc9c 1235 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
6224f72b 1236#else
3280af22 1237 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
6224f72b 1238#endif
3280af22 1239 sv_catpv(PL_Sv,"\" Compile-time options:");
6224f72b 1240# ifdef DEBUGGING
3280af22 1241 sv_catpv(PL_Sv," DEBUGGING");
6224f72b 1242# endif
6224f72b 1243# ifdef MULTIPLICITY
8f872242 1244 sv_catpv(PL_Sv," MULTIPLICITY");
6224f72b 1245# endif
4d1ff10f
AB		 1246# ifdef USE_5005THREADS
1247 sv_catpv(PL_Sv," USE_5005THREADS");
b363f7ed 1248# endif
ac5e8965
JH		 1249# ifdef USE_ITHREADS
1250 sv_catpv(PL_Sv," USE_ITHREADS");
1251# endif
10cc9d2a
JH		 1252# ifdef USE_64_BIT_INT
1253 sv_catpv(PL_Sv," USE_64_BIT_INT");
1254# endif
1255# ifdef USE_64_BIT_ALL
1256 sv_catpv(PL_Sv," USE_64_BIT_ALL");
ac5e8965
JH		 1257# endif
1258# ifdef USE_LONG_DOUBLE
1259 sv_catpv(PL_Sv," USE_LONG_DOUBLE");
1260# endif
53430762
JH		 1261# ifdef USE_LARGE_FILES
1262 sv_catpv(PL_Sv," USE_LARGE_FILES");
1263# endif
ac5e8965
JH		 1264# ifdef USE_SOCKS
1265 sv_catpv(PL_Sv," USE_SOCKS");
1266# endif
b363f7ed
GS		 1267# ifdef PERL_IMPLICIT_CONTEXT
1268 sv_catpv(PL_Sv," PERL_IMPLICIT_CONTEXT");
1269# endif
1270# ifdef PERL_IMPLICIT_SYS
1271 sv_catpv(PL_Sv," PERL_IMPLICIT_SYS");
1272# endif
3280af22 1273 sv_catpv(PL_Sv,"\\n\",");
b363f7ed 1274
6224f72b
GS		 1275#if defined(LOCAL_PATCH_COUNT)
1276 if (LOCAL_PATCH_COUNT > 0) {
1277 int i;
3280af22 1278 sv_catpv(PL_Sv,"\" Locally applied patches:\\n\",");
6224f72b 1279 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
3280af22 1280 if (PL_localpatches[i])
cea2e8a9 1281 Perl_sv_catpvf(aTHX_ PL_Sv,"q\" \t%s\n\",",PL_localpatches[i]);
6224f72b
GS		 1282 }
1283 }
1284#endif
cea2e8a9 1285 Perl_sv_catpvf(aTHX_ PL_Sv,"\" Built under %s\\n\"",OSNAME);
6224f72b
GS		 1286#ifdef __DATE__
1287# ifdef __TIME__
cea2e8a9 1288 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
6224f72b 1289# else
cea2e8a9 1290 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled on %s\\n\"",__DATE__);
6224f72b
GS		 1291# endif
1292#endif
3280af22 1293 sv_catpv(PL_Sv, "; \
6224f72b 1294$\"=\"\\n \"; \
69fcd688
JH		 1295@env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; ");
1296#ifdef __CYGWIN__
1297 sv_catpv(PL_Sv,"\
1298push @env, \"CYGWIN=\\\"$ENV{CYGWIN}\\\"\";");
1299#endif
1300 sv_catpv(PL_Sv, "\
6224f72b
GS		 1301print \" \\%ENV:\\n @env\\n\" if @env; \
1302print \" \\@INC:\\n @INC\\n\";");
1303 }
1304 else {
3280af22
NIS		 1305 PL_Sv = newSVpv("config_vars(qw(",0);
1306 sv_catpv(PL_Sv, ++s);
1307 sv_catpv(PL_Sv, "))");
6224f72b
GS		 1308 s += strlen(s);
1309 }
3280af22 1310 av_push(PL_preambleav, PL_Sv);
6224f72b
GS		 1311 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
1312 goto reswitch;
1313 case 'x':
3280af22 1314 PL_doextract = TRUE;
6224f72b
GS		 1315 s++;
1316 if (*s)
f4c556ac 1317 cddir = s;
6224f72b
GS		 1318 break;
1319 case 0:
1320 break;
1321 case '-':
1322 if (!*++s || isSPACE(*s)) {
1323 argc--,argv++;
1324 goto switch_end;
1325 }
1326 /* catch use of gnu style long options */
1327 if (strEQ(s, "version")) {
1328 s = "v";
1329 goto reswitch;
1330 }
1331 if (strEQ(s, "help")) {
1332 s = "h";
1333 goto reswitch;
1334 }
1335 s--;
1336 /* FALL THROUGH */
1337 default:
cea2e8a9 1338 Perl_croak(aTHX_ "Unrecognized switch: -%s (-h will show valid options)",s);
8d063cd8
LW		 1339 }
1340 }
6224f72b 1341 switch_end:
7f9e821f 1342 sv_setsv(get_sv("/", TRUE), PL_rs);
54310121 1343
f675dbe5
CB		 1344 if (
1345#ifndef SECURE_INTERNAL_GETENV
1346 !PL_tainting &&
1347#endif
cf756827 1348 (s = PerlEnv_getenv("PERL5OPT")))
0df16ed7 1349 {
cf756827 1350 char *popt = s;
74288ac8
GS		 1351 while (isSPACE(*s))
1352 s++;
317ea90d 1353 if (*s == '-' && *(s+1) == 'T') {
74288ac8 1354 PL_tainting = TRUE;
317ea90d
MS		 1355 PL_taint_warn = FALSE;
1356 }
74288ac8 1357 else {
cf756827 1358 char *popt_copy = Nullch;
74288ac8 1359 while (s && *s) {
4ea8f8fb 1360 char *d;
74288ac8
GS		 1361 while (isSPACE(*s))
1362 s++;
1363 if (*s == '-') {
1364 s++;
1365 if (isSPACE(*s))
1366 continue;
1367 }
4ea8f8fb 1368 d = s;
74288ac8
GS		 1369 if (!*s)
1370 break;
1c4db469 1371 if (!strchr("DIMUdmtw", *s))
cea2e8a9 1372 Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s);
4ea8f8fb
MS		 1373 while (++s && *s) {
1374 if (isSPACE(*s)) {
cf756827
GS		 1375 if (!popt_copy) {
1376 popt_copy = SvPVX(sv_2mortal(newSVpv(popt,0)));
1377 s = popt_copy + (s - popt);
1378 d = popt_copy + (d - popt);
1379 }
4ea8f8fb
MS		 1380 *s++ = '\0';
1381 break;
1382 }
1383 }
1c4db469 1384 if (*d == 't') {
317ea90d
MS		 1385 if( !PL_tainting ) {
1386 PL_taint_warn = TRUE;
1387 PL_tainting = TRUE;
1388 }
1c4db469
RGS		 1389 } else {
1390 moreswitches(d);
1391 }
6224f72b 1392 }
6224f72b
GS		 1393 }
1394 }
a0d0e21e 1395
317ea90d
MS		 1396 if (PL_taint_warn && PL_dowarn != G_WARN_ALL_OFF) {
1397 PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
1398 }
1399
6224f72b
GS		 1400 if (!scriptname)
1401 scriptname = argv[0];
3280af22 1402 if (PL_e_script) {
6224f72b
GS		 1403 argc++,argv--;
1404 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
1405 }
1406 else if (scriptname == Nullch) {
1407#ifdef MSDOS
1408 if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
1409 moreswitches("h");
1410#endif
1411 scriptname = "-";
1412 }
1413
1414 init_perllib();
1415
1416 open_script(scriptname,dosearch,sv,&fdscript);
1417
1418 validate_suid(validarg, scriptname,fdscript);
1419
64ca3a65 1420#ifndef PERL_MICRO
0b5b802d
GS		 1421#if defined(SIGCHLD) || defined(SIGCLD)
1422 {
1423#ifndef SIGCHLD
1424# define SIGCHLD SIGCLD
1425#endif
1426 Sighandler_t sigstate = rsignal_state(SIGCHLD);
1427 if (sigstate == SIG_IGN) {
1428 if (ckWARN(WARN_SIGNAL))
9014280d 1429 Perl_warner(aTHX_ packWARN(WARN_SIGNAL),
0b5b802d
GS		 1430 "Can't ignore signal CHLD, forcing to default");
1431 (void)rsignal(SIGCHLD, (Sighandler_t)SIG_DFL);
1432 }
1433 }
1434#endif
64ca3a65 1435#endif
0b5b802d 1436
bf4acbe4
GS		 1437#ifdef MACOS_TRADITIONAL
1438 if (PL_doextract || gMacPerl_AlwaysExtract) {
1439#else
f4c556ac 1440 if (PL_doextract) {
bf4acbe4 1441#endif
6224f72b 1442 find_beginning();
f4c556ac
GS		 1443 if (cddir && PerlDir_chdir(cddir) < 0)
1444 Perl_croak(aTHX_ "Can't chdir to %s",cddir);
1445
1446 }
6224f72b 1447
3280af22
NIS		 1448 PL_main_cv = PL_compcv = (CV*)NEWSV(1104,0);
1449 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
1450 CvUNIQUE_on(PL_compcv);
1451
dd2155a4 1452 CvPADLIST(PL_compcv) = pad_new(0);
4d1ff10f 1453#ifdef USE_5005THREADS
533c011a
NIS		 1454 CvOWNER(PL_compcv) = 0;
1455 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
1456 MUTEX_INIT(CvMUTEXP(PL_compcv));
4d1ff10f 1457#endif /* USE_5005THREADS */
6224f72b 1458
0c4f7ff0 1459 boot_core_PerlIO();
6224f72b 1460 boot_core_UNIVERSAL();
9a34ef1d 1461#ifndef PERL_MICRO
09bef843 1462 boot_core_xsutils();
9a34ef1d 1463#endif
6224f72b
GS		 1464
1465 if (xsinit)
acfe0abc 1466 (*xsinit)(aTHX); /* in case linked C routines want magical variables */
64ca3a65 1467#ifndef PERL_MICRO
ed79a026 1468#if defined(VMS) || defined(WIN32) || defined(DJGPP) || defined(__CYGWIN__) || defined(EPOC)
c5be433b 1469 init_os_extras();
6224f72b 1470#endif
64ca3a65 1471#endif
6224f72b 1472
29209bc5 1473#ifdef USE_SOCKS
1b9c9cf5
DH		 1474# ifdef HAS_SOCKS5_INIT
1475 socks5_init(argv[0]);
1476# else
29209bc5 1477 SOCKSinit(argv[0]);
1b9c9cf5 1478# endif
ac27b0f5 1479#endif
29209bc5 1480
6224f72b
GS		 1481 init_predump_symbols();
1482 /* init_postdump_symbols not currently designed to be called */
1483 /* more than once (ENV isn't cleared first, for example) */
1484 /* But running with -u leaves %ENV & @ARGV undefined! XXX */
3280af22 1485 if (!PL_do_undump)
6224f72b
GS		 1486 init_postdump_symbols(argc,argv,env);
1487
085a54d9
JH		 1488 /* PL_wantutf8 is conditionally turned on by
1489 * locale.c:Perl_init_i18nl10n() if the environment
1490 * look like the user wants to use UTF-8. */
b310b053
JH		 1491 if (PL_wantutf8) { /* Requires init_predump_symbols(). */
1492 IO* io;
1493 PerlIO* fp;
1494 SV* sv;
085a54d9
JH		 1495 /* Turn on UTF-8-ness on STDIN, STDOUT, STDERR
1496 * _and_ the default open discipline. */
b310b053
JH		 1497 if (PL_stdingv && (io = GvIO(PL_stdingv)) && (fp = IoIFP(io)))
1498 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
1499 if (PL_defoutgv && (io = GvIO(PL_defoutgv)) && (fp = IoOFP(io)))
1500 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
1501 if (PL_stderrgv && (io = GvIO(PL_stderrgv)) && (fp = IoOFP(io)))
1502 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
1503 if ((sv = GvSV(gv_fetchpv("\017PEN", TRUE, SVt_PV)))) {
1504 sv_setpvn(sv, ":utf8\0:utf8", 11);
1505 SvSETMAGIC(sv);
1506 }
1507 }
1508
6224f72b
GS		 1509 init_lexer();
1510
1511 /* now parse the script */
1512
93189314 1513 SETERRNO(0,SS_NORMAL);
3280af22 1514 PL_error_count = 0;
bf4acbe4
GS		 1515#ifdef MACOS_TRADITIONAL
1516 if (gMacPerl_SyntaxError = (yyparse() || PL_error_count)) {
1517 if (PL_minus_c)
1518 Perl_croak(aTHX_ "%s had compilation errors.\n", MacPerl_MPWFileName(PL_origfilename));
1519 else {
1520 Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
1521 MacPerl_MPWFileName(PL_origfilename));
1522 }
1523 }
1524#else
3280af22
NIS		 1525 if (yyparse() || PL_error_count) {
1526 if (PL_minus_c)
cea2e8a9 1527 Perl_croak(aTHX_ "%s had compilation errors.\n", PL_origfilename);
6224f72b 1528 else {
cea2e8a9 1529 Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
097ee67d 1530 PL_origfilename);
6224f72b
GS		 1531 }
1532 }
bf4acbe4 1533#endif
57843af0 1534 CopLINE_set(PL_curcop, 0);
3280af22
NIS		 1535 PL_curstash = PL_defstash;
1536 PL_preprocess = FALSE;
1537 if (PL_e_script) {
1538 SvREFCNT_dec(PL_e_script);
1539 PL_e_script = Nullsv;
6224f72b
GS		 1540 }
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 */
7bab3ede 2341 static char debopts[] = "psltocPmfrxu HXDSTRJvC";
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));
4633a7c4 2758 /* We must init $/ before switches are processed. */
864dbfa3 2759 sv_setpvn(get_sv("/", TRUE), "\n", 1);
79072805
LW		 2760}
2761
76e3520e 2762STATIC void
cea2e8a9 2763S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript)
79072805 2764{
1b24ed4b
MS		 2765 char *quote;
2766 char *code;
2767 char *cpp_discard_flag;
2768 char *perl;
2769
6c4ab083 2770 *fdscript = -1;
79072805 2771
3280af22
NIS		 2772 if (PL_e_script) {
2773 PL_origfilename = savepv("-e");
96436eeb 2774 }
6c4ab083
GS		 2775 else {
2776 /* if find_script() returns, it returns a malloc()-ed value */
3280af22 2777 PL_origfilename = scriptname = find_script(scriptname, dosearch, NULL, 1);
6c4ab083
GS		 2778
2779 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
2780 char *s = scriptname + 8;
2781 *fdscript = atoi(s);
2782 while (isDIGIT(*s))
2783 s++;
2784 if (*s) {
2785 scriptname = savepv(s + 1);
3280af22
NIS		 2786 Safefree(PL_origfilename);
2787 PL_origfilename = scriptname;
6c4ab083
GS		 2788 }
2789 }
2790 }
2791
05ec9bb3 2792 CopFILE_free(PL_curcop);
57843af0 2793 CopFILE_set(PL_curcop, PL_origfilename);
3280af22 2794 if (strEQ(PL_origfilename,"-"))
79072805 2795 scriptname = "";
01f988be 2796 if (*fdscript >= 0) {
3280af22 2797 PL_rsfp = PerlIO_fdopen(*fdscript,PERL_SCRIPT_MODE);
1b24ed4b
MS		 2798# if defined(HAS_FCNTL) && defined(F_SETFD)
2799 if (PL_rsfp)
2800 /* ensure close-on-exec */
2801 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);
2802# endif
96436eeb 2803 }
3280af22 2804 else if (PL_preprocess) {
46fc3d4c 2805 char *cpp_cfg = CPPSTDIN;
79cb57f6 2806 SV *cpp = newSVpvn("",0);
46fc3d4c 2807 SV *cmd = NEWSV(0,0);
2808
2809 if (strEQ(cpp_cfg, "cppstdin"))
cea2e8a9 2810 Perl_sv_catpvf(aTHX_ cpp, "%s/", BIN_EXP);
46fc3d4c 2811 sv_catpv(cpp, cpp_cfg);
79072805 2812
1b24ed4b
MS		 2813# ifndef VMS
2814 sv_catpvn(sv, "-I", 2);
2815 sv_catpv(sv,PRIVLIB_EXP);
2816# endif
46fc3d4c 2817
14953ddc
MB		 2818 DEBUG_P(PerlIO_printf(Perl_debug_log,
2819 "PL_preprocess: scriptname=\"%s\", cpp=\"%s\", sv=\"%s\", CPPMINUS=\"%s\"\n",
2820 scriptname, SvPVX (cpp), SvPVX (sv), CPPMINUS));
1b24ed4b
MS		 2821
2822# if defined(MSDOS) || defined(WIN32) || defined(VMS)
2823 quote = "\"";
2824# else
2825 quote = "'";
2826# endif
2827
2828# ifdef VMS
2829 cpp_discard_flag = "";
2830# else
2831 cpp_discard_flag = "-C";
2832# endif
2833
2834# ifdef OS2
2835 perl = os2_execname(aTHX);
2836# else
2837 perl = PL_origargv[0];
2838# endif
2839
2840
2841 /* This strips off Perl comments which might interfere with
62375a60
NIS		 2842 the C pre-processor, including #!. #line directives are
2843 deliberately stripped to avoid confusion with Perl's version
1b24ed4b
MS		 2844 of #line. FWP played some golf with it so it will fit
2845 into VMS's 255 character buffer.
2846 */
2847 if( PL_doextract )
2848 code = "(1../^#!.*perl/i)|/^\\s*#(?!\\s*((ifn?|un)def|(el|end)?if|define|include|else|error|pragma)\\b)/||!($|=1)||print";
2849 else
2850 code = "/^\\s*#(?!\\s*((ifn?|un)def|(el|end)?if|define|include|else|error|pragma)\\b)/||!($|=1)||print";
2851
2852 Perl_sv_setpvf(aTHX_ cmd, "\
2853%s -ne%s%s%s %s | %"SVf" %s %"SVf" %s",
62375a60 2854 perl, quote, code, quote, scriptname, cpp,
1b24ed4b
MS		 2855 cpp_discard_flag, sv, CPPMINUS);
2856
3280af22 2857 PL_doextract = FALSE;
1b24ed4b
MS		 2858# ifdef IAMSUID /* actually, this is caught earlier */
2859 if (PL_euid != PL_uid && !PL_euid) { /* if running suidperl */
2860# ifdef HAS_SETEUID
2861 (void)seteuid(PL_uid); /* musn't stay setuid root */
2862# else
2863# ifdef HAS_SETREUID
2864 (void)setreuid((Uid_t)-1, PL_uid);
2865# else
2866# ifdef HAS_SETRESUID
2867 (void)setresuid((Uid_t)-1, PL_uid, (Uid_t)-1);
2868# else
2869 PerlProc_setuid(PL_uid);
2870# endif
2871# endif
2872# endif
b28d0864 2873 if (PerlProc_geteuid() != PL_uid)
cea2e8a9 2874 Perl_croak(aTHX_ "Can't do seteuid!\n");
79072805 2875 }
1b24ed4b 2876# endif /* IAMSUID */
0a6c758d 2877
62375a60
NIS		 2878 DEBUG_P(PerlIO_printf(Perl_debug_log,
2879 "PL_preprocess: cmd=\"%s\"\n",
0a6c758d
MS		 2880 SvPVX(cmd)));
2881
3280af22 2882 PL_rsfp = PerlProc_popen(SvPVX(cmd), "r");
46fc3d4c 2883 SvREFCNT_dec(cmd);
2884 SvREFCNT_dec(cpp);
79072805
LW		 2885 }
2886 else if (!*scriptname) {
bbce6d69 2887 forbid_setid("program input from stdin");
3280af22 2888 PL_rsfp = PerlIO_stdin();
79072805 2889 }
96436eeb 2890 else {
3280af22 2891 PL_rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
1b24ed4b
MS		 2892# if defined(HAS_FCNTL) && defined(F_SETFD)
2893 if (PL_rsfp)
2894 /* ensure close-on-exec */
2895 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);
2896# endif
96436eeb 2897 }
3280af22 2898 if (!PL_rsfp) {
1b24ed4b
MS		 2899# ifdef DOSUID
2900# ifndef IAMSUID /* in case script is not readable before setuid */
2901 if (PL_euid &&
2902 PerlLIO_stat(CopFILE(PL_curcop),&PL_statbuf) >= 0 &&
2903 PL_statbuf.st_mode & (S_ISUID|S_ISGID))
2904 {
2905 /* try again */
62375a60
NIS		 2906 PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT,
2907 BIN_EXP, (int)PERL_REVISION,
1b24ed4b
MS		 2908 (int)PERL_VERSION,
2909 (int)PERL_SUBVERSION), PL_origargv);
2910 Perl_croak(aTHX_ "Can't do setuid\n");
2911 }
2912# endif
2913# endif
2914# ifdef IAMSUID
2915 errno = EPERM;
2916 Perl_croak(aTHX_ "Can't open perl script: %s\n",
2917 Strerror(errno));
2918# else
2919 Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
2920 CopFILE(PL_curcop), Strerror(errno));
2921# endif
13281fa4 2922 }
79072805 2923}
8d063cd8 2924
7b89560d
JH		 2925/* Mention
2926 * I_SYSSTATVFS HAS_FSTATVFS
2927 * I_SYSMOUNT
c890dc6c 2928 * I_STATFS HAS_FSTATFS HAS_GETFSSTAT
7b89560d
JH		 2929 * I_MNTENT HAS_GETMNTENT HAS_HASMNTOPT
2930 * here so that metaconfig picks them up. */
2931
104d25b7 2932#ifdef IAMSUID
864dbfa3 2933STATIC int
e688b231 2934S_fd_on_nosuid_fs(pTHX_ int fd)
104d25b7 2935{
0545a864
JH		 2936 int check_okay = 0; /* able to do all the required sys/libcalls */
2937 int on_nosuid = 0; /* the fd is on a nosuid fs */
104d25b7 2938/*
ad27e871 2939 * Preferred order: fstatvfs(), fstatfs(), ustat()+getmnt(), getmntent().
e688b231 2940 * fstatvfs() is UNIX98.
0545a864 2941 * fstatfs() is 4.3 BSD.
ad27e871 2942 * ustat()+getmnt() is pre-4.3 BSD.
0545a864
JH		 2943 * getmntent() is O(number-of-mounted-filesystems) and can hang on
2944 * an irrelevant filesystem while trying to reach the right one.
104d25b7
JH		 2945 */
2946
6439433f
JH		 2947#undef FD_ON_NOSUID_CHECK_OKAY /* found the syscalls to do the check? */
2948
2949# if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
2950 defined(HAS_FSTATVFS)
2951# define FD_ON_NOSUID_CHECK_OKAY
104d25b7 2952 struct statvfs stfs;
6439433f 2953
104d25b7
JH		 2954 check_okay = fstatvfs(fd, &stfs) == 0;
2955 on_nosuid = check_okay && (stfs.f_flag & ST_NOSUID);
6439433f 2956# endif /* fstatvfs */
ac27b0f5 2957
6439433f
JH		 2958# if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
2959 defined(PERL_MOUNT_NOSUID) && \
2960 defined(HAS_FSTATFS) && \
2961 defined(HAS_STRUCT_STATFS) && \
2962 defined(HAS_STRUCT_STATFS_F_FLAGS)
2963# define FD_ON_NOSUID_CHECK_OKAY
e688b231 2964 struct statfs stfs;
6439433f 2965
104d25b7 2966 check_okay = fstatfs(fd, &stfs) == 0;
104d25b7 2967 on_nosuid = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID);
6439433f
JH		 2968# endif /* fstatfs */
2969
2970# if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
2971 defined(PERL_MOUNT_NOSUID) && \
2972 defined(HAS_FSTAT) && \
2973 defined(HAS_USTAT) && \
2974 defined(HAS_GETMNT) && \
2975 defined(HAS_STRUCT_FS_DATA) && \
2976 defined(NOSTAT_ONE)
2977# define FD_ON_NOSUID_CHECK_OKAY
c623ac67 2978 Stat_t fdst;
6439433f 2979
0545a864 2980 if (fstat(fd, &fdst) == 0) {
6439433f
JH		 2981 struct ustat us;
2982 if (ustat(fdst.st_dev, &us) == 0) {
2983 struct fs_data fsd;
2984 /* NOSTAT_ONE here because we're not examining fields which
2985 * vary between that case and STAT_ONE. */
ad27e871 2986 if (getmnt((int*)0, &fsd, (int)0, NOSTAT_ONE, us.f_fname) == 0) {
6439433f
JH		 2987 size_t cmplen = sizeof(us.f_fname);
2988 if (sizeof(fsd.fd_req.path) < cmplen)
2989 cmplen = sizeof(fsd.fd_req.path);
2990 if (strnEQ(fsd.fd_req.path, us.f_fname, cmplen) &&
2991 fdst.st_dev == fsd.fd_req.dev) {
2992 check_okay = 1;
2993 on_nosuid = fsd.fd_req.flags & PERL_MOUNT_NOSUID;
2994 }
2995 }
2996 }
2997 }
0545a864 2998 }
6439433f
JH		 2999# endif /* fstat+ustat+getmnt */
3000
3001# if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
3002 defined(HAS_GETMNTENT) && \
3003 defined(HAS_HASMNTOPT) && \
3004 defined(MNTOPT_NOSUID)
3005# define FD_ON_NOSUID_CHECK_OKAY
3006 FILE *mtab = fopen("/etc/mtab", "r");
3007 struct mntent *entry;
c623ac67 3008 Stat_t stb, fsb;
104d25b7
JH		 3009
3010 if (mtab && (fstat(fd, &stb) == 0)) {
6439433f
JH		 3011 while (entry = getmntent(mtab)) {
3012 if (stat(entry->mnt_dir, &fsb) == 0
3013 && fsb.st_dev == stb.st_dev)
3014 {
3015 /* found the filesystem */
3016 check_okay = 1;
3017 if (hasmntopt(entry, MNTOPT_NOSUID))
3018 on_nosuid = 1;
3019 break;
3020 } /* A single fs may well fail its stat(). */
3021 }
104d25b7
JH		 3022 }
3023 if (mtab)
6439433f
JH		 3024 fclose(mtab);
3025# endif /* getmntent+hasmntopt */
0545a864 3026
ac27b0f5 3027 if (!check_okay)
0545a864 3028 Perl_croak(aTHX_ "Can't check filesystem of script \"%s\" for nosuid", PL_origfilename);
104d25b7
JH		 3029 return on_nosuid;
3030}
3031#endif /* IAMSUID */
3032
76e3520e 3033STATIC void
cea2e8a9 3034S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript)
79072805 3035{
155aba94 3036#ifdef IAMSUID
96436eeb 3037 int which;
155aba94 3038#endif
96436eeb 3039
13281fa4
LW		 3040 /* do we need to emulate setuid on scripts? */
3041
3042 /* This code is for those BSD systems that have setuid #! scripts disabled
3043 * in the kernel because of a security problem. Merely defining DOSUID
3044 * in perl will not fix that problem, but if you have disabled setuid
3045 * scripts in the kernel, this will attempt to emulate setuid and setgid
3046 * on scripts that have those now-otherwise-useless bits set. The setuid
27e2fb84
LW		 3047 * root version must be called suidperl or sperlN.NNN. If regular perl
3048 * discovers that it has opened a setuid script, it calls suidperl with
3049 * the same argv that it had. If suidperl finds that the script it has
3050 * just opened is NOT setuid root, it sets the effective uid back to the
3051 * uid. We don't just make perl setuid root because that loses the
3052 * effective uid we had before invoking perl, if it was different from the
3053 * uid.
13281fa4
LW		 3054 *
3055 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
3056 * be defined in suidperl only. suidperl must be setuid root. The
3057 * Configure script will set this up for you if you want it.
3058 */
a687059c 3059
13281fa4 3060#ifdef DOSUID
6e72f9df 3061 char *s, *s2;
a0d0e21e 3062
b28d0864 3063 if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0) /* normal stat is insecure */
cea2e8a9 3064 Perl_croak(aTHX_ "Can't stat script \"%s\"",PL_origfilename);
b28d0864 3065 if (fdscript < 0 && PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
79072805 3066 I32 len;
2d8e6c8d 3067 STRLEN n_a;
13281fa4 3068
a687059c 3069#ifdef IAMSUID
fe14fcc3 3070#ifndef HAS_SETREUID
a687059c
LW		 3071 /* On this access check to make sure the directories are readable,
3072 * there is actually a small window that the user could use to make
3073 * filename point to an accessible directory. So there is a faint
3074 * chance that someone could execute a setuid script down in a
3075 * non-accessible directory. I don't know what to do about that.
3076 * But I don't think it's too important. The manual lies when
3077 * it says access() is useful in setuid programs.
3078 */
cc49e20b 3079 if (PerlLIO_access(CopFILE(PL_curcop),1)) /*double check*/
cea2e8a9 3080 Perl_croak(aTHX_ "Permission denied");
a687059c
LW		 3081#else
3082 /* If we can swap euid and uid, then we can determine access rights
3083 * with a simple stat of the file, and then compare device and
3084 * inode to make sure we did stat() on the same file we opened.
3085 * Then we just have to make sure he or she can execute it.
3086 */
3087 {
c623ac67 3088 Stat_t tmpstatbuf;
a687059c 3089
85e6fe83
LW		 3090 if (
3091#ifdef HAS_SETREUID
b28d0864 3092 setreuid(PL_euid,PL_uid) < 0
a0d0e21e
LW		 3093#else
3094# if HAS_SETRESUID
b28d0864 3095 setresuid(PL_euid,PL_uid,(Uid_t)-1) < 0
a0d0e21e 3096# endif
85e6fe83 3097#endif
b28d0864 3098 || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
cea2e8a9 3099 Perl_croak(aTHX_ "Can't swap uid and euid"); /* really paranoid */
cc49e20b 3100 if (PerlLIO_stat(CopFILE(PL_curcop),&tmpstatbuf) < 0)
cea2e8a9 3101 Perl_croak(aTHX_ "Permission denied"); /* testing full pathname here */
2bb3463c 3102#if defined(IAMSUID) && !defined(NO_NOSUID_CHECK)
e688b231 3103 if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp)))
cea2e8a9 3104 Perl_croak(aTHX_ "Permission denied");
104d25b7 3105#endif
b28d0864
NIS		 3106 if (tmpstatbuf.st_dev != PL_statbuf.st_dev ||
3107 tmpstatbuf.st_ino != PL_statbuf.st_ino) {
3108 (void)PerlIO_close(PL_rsfp);
cea2e8a9 3109 Perl_croak(aTHX_ "Permission denied\n");
a687059c 3110 }
85e6fe83
LW		 3111 if (
3112#ifdef HAS_SETREUID
b28d0864 3113 setreuid(PL_uid,PL_euid) < 0
a0d0e21e
LW		 3114#else
3115# if defined(HAS_SETRESUID)
b28d0864 3116 setresuid(PL_uid,PL_euid,(Uid_t)-1) < 0
a0d0e21e 3117# endif
85e6fe83 3118#endif
b28d0864 3119 || PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid)
cea2e8a9 3120 Perl_croak(aTHX_ "Can't reswap uid and euid");
b28d0864 3121 if (!cando(S_IXUSR,FALSE,&PL_statbuf)) /* can real uid exec? */
cea2e8a9 3122 Perl_croak(aTHX_ "Permission denied\n");
a687059c 3123 }
fe14fcc3 3124#endif /* HAS_SETREUID */
a687059c
LW		 3125#endif /* IAMSUID */
3126
b28d0864 3127 if (!S_ISREG(PL_statbuf.st_mode))
cea2e8a9 3128 Perl_croak(aTHX_ "Permission denied");
b28d0864 3129 if (PL_statbuf.st_mode & S_IWOTH)
cea2e8a9 3130 Perl_croak(aTHX_ "Setuid/gid script is writable by world");
6b88bc9c 3131 PL_doswitches = FALSE; /* -s is insecure in suid */
57843af0 3132 CopLINE_inc(PL_curcop);
6b88bc9c 3133 if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch ||
2d8e6c8d 3134 strnNE(SvPV(PL_linestr,n_a),"#!",2) ) /* required even on Sys V */
cea2e8a9 3135 Perl_croak(aTHX_ "No #! line");
2d8e6c8d 3136 s = SvPV(PL_linestr,n_a)+2;
663a0e37 3137 if (*s == ' ') s++;
45d8adaa 3138 while (!isSPACE(*s)) s++;
2d8e6c8d 3139 for (s2 = s; (s2 > SvPV(PL_linestr,n_a)+2 &&
6e72f9df 3140 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
3141 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
cea2e8a9 3142 Perl_croak(aTHX_ "Not a perl script");
a687059c 3143 while (*s == ' ' || *s == '\t') s++;
13281fa4
LW		 3144 /*
3145 * #! arg must be what we saw above. They can invoke it by
3146 * mentioning suidperl explicitly, but they may not add any strange
3147 * arguments beyond what #! says if they do invoke suidperl that way.
3148 */
3149 len = strlen(validarg);
3150 if (strEQ(validarg," PHOOEY ") ||
45d8adaa 3151 strnNE(s,validarg,len) || !isSPACE(s[len]))
cea2e8a9 3152 Perl_croak(aTHX_ "Args must match #! line");
a687059c
LW		 3153
3154#ifndef IAMSUID
b28d0864
NIS		 3155 if (PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
3156 PL_euid == PL_statbuf.st_uid)
3157 if (!PL_do_undump)
cea2e8a9 3158 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
a687059c
LW		 3159FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
3160#endif /* IAMSUID */
13281fa4 3161
b28d0864
NIS		 3162 if (PL_euid) { /* oops, we're not the setuid root perl */
3163 (void)PerlIO_close(PL_rsfp);
13281fa4 3164#ifndef IAMSUID
46fc3d4c 3165 /* try again */
a7cb1f99 3166 PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, BIN_EXP,
273cf8d1
GS		 3167 (int)PERL_REVISION, (int)PERL_VERSION,
3168 (int)PERL_SUBVERSION), PL_origargv);
13281fa4 3169#endif
cea2e8a9 3170 Perl_croak(aTHX_ "Can't do setuid\n");
13281fa4
LW		 3171 }
3172
b28d0864 3173 if (PL_statbuf.st_mode & S_ISGID && PL_statbuf.st_gid != PL_egid) {
fe14fcc3 3174#ifdef HAS_SETEGID
b28d0864 3175 (void)setegid(PL_statbuf.st_gid);
a687059c 3176#else
fe14fcc3 3177#ifdef HAS_SETREGID
b28d0864 3178 (void)setregid((Gid_t)-1,PL_statbuf.st_gid);
85e6fe83
LW		 3179#else
3180#ifdef HAS_SETRESGID
b28d0864 3181 (void)setresgid((Gid_t)-1,PL_statbuf.st_gid,(Gid_t)-1);
a687059c 3182#else
b28d0864 3183 PerlProc_setgid(PL_statbuf.st_gid);
a687059c
LW		 3184#endif
3185#endif
85e6fe83 3186#endif
b28d0864 3187 if (PerlProc_getegid() != PL_statbuf.st_gid)
cea2e8a9 3188 Perl_croak(aTHX_ "Can't do setegid!\n");
83025b21 3189 }
b28d0864
NIS		 3190 if (PL_statbuf.st_mode & S_ISUID) {
3191 if (PL_statbuf.st_uid != PL_euid)
fe14fcc3 3192#ifdef HAS_SETEUID
b28d0864 3193 (void)seteuid(PL_statbuf.st_uid); /* all that for this */
a687059c 3194#else
fe14fcc3 3195#ifdef HAS_SETREUID
b28d0864 3196 (void)setreuid((Uid_t)-1,PL_statbuf.st_uid);
85e6fe83
LW		 3197#else
3198#ifdef HAS_SETRESUID
b28d0864 3199 (void)setresuid((Uid_t)-1,PL_statbuf.st_uid,(Uid_t)-1);
a687059c 3200#else
b28d0864 3201 PerlProc_setuid(PL_statbuf.st_uid);
a687059c
LW		 3202#endif
3203#endif
85e6fe83 3204#endif
b28d0864 3205 if (PerlProc_geteuid() != PL_statbuf.st_uid)
cea2e8a9 3206 Perl_croak(aTHX_ "Can't do seteuid!\n");
a687059c 3207 }
b28d0864 3208 else if (PL_uid) { /* oops, mustn't run as root */
fe14fcc3 3209#ifdef HAS_SETEUID
b28d0864 3210 (void)seteuid((Uid_t)PL_uid);
a687059c 3211#else
fe14fcc3 3212#ifdef HAS_SETREUID
b28d0864 3213 (void)setreuid((Uid_t)-1,(Uid_t)PL_uid);
a687059c 3214#else
85e6fe83 3215#ifdef HAS_SETRESUID
b28d0864 3216 (void)setresuid((Uid_t)-1,(Uid_t)PL_uid,(Uid_t)-1);
85e6fe83 3217#else
b28d0864 3218 PerlProc_setuid((Uid_t)PL_uid);
85e6fe83 3219#endif
a687059c
LW		 3220#endif
3221#endif
b28d0864 3222 if (PerlProc_geteuid() != PL_uid)
cea2e8a9 3223 Perl_croak(aTHX_ "Can't do seteuid!\n");
83025b21 3224 }
748a9306 3225 init_ids();
b28d0864 3226 if (!cando(S_IXUSR,TRUE,&PL_statbuf))
cea2e8a9 3227 Perl_croak(aTHX_ "Permission denied\n"); /* they can't do this */
13281fa4
LW		 3228 }
3229#ifdef IAMSUID
6b88bc9c 3230 else if (PL_preprocess)
cea2e8a9 3231 Perl_croak(aTHX_ "-P not allowed for setuid/setgid script\n");
96436eeb 3232 else if (fdscript >= 0)
cea2e8a9 3233 Perl_croak(aTHX_ "fd script not allowed in suidperl\n");
13281fa4 3234 else
cea2e8a9 3235 Perl_croak(aTHX_ "Script is not setuid/setgid in suidperl\n");
96436eeb 3236
3237 /* We absolutely must clear out any saved ids here, so we */
3238 /* exec the real perl, substituting fd script for scriptname. */
3239 /* (We pass script name as "subdir" of fd, which perl will grok.) */
b28d0864
NIS		 3240 PerlIO_rewind(PL_rsfp);
3241 PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0); /* just in case rewind didn't */
6b88bc9c
GS		 3242 for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;
3243 if (!PL_origargv[which])
cea2e8a9
GS		 3244 Perl_croak(aTHX_ "Permission denied");
3245 PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s",
6b88bc9c 3246 PerlIO_fileno(PL_rsfp), PL_origargv[which]));
96436eeb 3247#if defined(HAS_FCNTL) && defined(F_SETFD)
b28d0864 3248 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0); /* ensure no close-on-exec */
96436eeb 3249#endif
a7cb1f99 3250 PerlProc_execv(Perl_form(aTHX_ "%s/perl"PERL_FS_VER_FMT, BIN_EXP,
273cf8d1
GS		 3251 (int)PERL_REVISION, (int)PERL_VERSION,
3252 (int)PERL_SUBVERSION), PL_origargv);/* try again */
cea2e8a9 3253 Perl_croak(aTHX_ "Can't do setuid\n");
13281fa4 3254#endif /* IAMSUID */
a687059c 3255#else /* !DOSUID */
3280af22 3256 if (PL_euid != PL_uid || PL_egid != PL_gid) { /* (suidperl doesn't exist, in fact) */
a687059c 3257#ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
b28d0864
NIS		 3258 PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf); /* may be either wrapped or real suid */
3259 if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
a687059c 3260 ||
b28d0864 3261 (PL_egid != PL_gid && PL_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
a687059c 3262 )
b28d0864 3263 if (!PL_do_undump)
cea2e8a9 3264 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
a687059c
LW		 3265FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
3266#endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
3267 /* not set-id, must be wrapped */
a687059c 3268 }
13281fa4 3269#endif /* DOSUID */
79072805 3270}
13281fa4 3271
76e3520e 3272STATIC void
cea2e8a9 3273S_find_beginning(pTHX)
79072805 3274{
6e72f9df 3275 register char *s, *s2;
e55ac0fa
HS		 3276#ifdef MACOS_TRADITIONAL
3277 int maclines = 0;
3278#endif
33b78306
LW		 3279
3280 /* skip forward in input to the real script? */
3281
bbce6d69 3282 forbid_setid("-x");
bf4acbe4 3283#ifdef MACOS_TRADITIONAL
084592ab 3284 /* Since the Mac OS does not honor #! arguments for us, we do it ourselves */
ac27b0f5 3285
bf4acbe4
GS		 3286 while (PL_doextract || gMacPerl_AlwaysExtract) {
3287 if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
3288 if (!gMacPerl_AlwaysExtract)
3289 Perl_croak(aTHX_ "No Perl script found in input\n");
e55ac0fa 3290
bf4acbe4
GS		 3291 if (PL_doextract) /* require explicit override ? */
3292 if (!OverrideExtract(PL_origfilename))
3293 Perl_croak(aTHX_ "User aborted script\n");
3294 else
3295 PL_doextract = FALSE;
e55ac0fa 3296
bf4acbe4
GS		 3297 /* Pater peccavi, file does not have #! */
3298 PerlIO_rewind(PL_rsfp);
e55ac0fa 3299
bf4acbe4
GS		 3300 break;
3301 }
3302#else
3280af22
NIS		 3303 while (PL_doextract) {
3304 if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch)
cea2e8a9 3305 Perl_croak(aTHX_ "No Perl script found in input\n");
bf4acbe4 3306#endif
4f0c37ba
IZ		 3307 s2 = s;
3308 if (*s == '#' && s[1] == '!' && ((s = instr(s,"perl")) || (s = instr(s2,"PERL")))) {
3280af22
NIS		 3309 PerlIO_ungetc(PL_rsfp, '\n'); /* to keep line count right */
3310 PL_doextract = FALSE;
6e72f9df 3311 while (*s && !(isSPACE (*s) || *s == '#')) s++;
3312 s2 = s;
3313 while (*s == ' ' || *s == '\t') s++;
3314 if (*s++ == '-') {
3315 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
3316 if (strnEQ(s2-4,"perl",4))
3317 /*SUPPRESS 530*/
155aba94
GS		 3318 while ((s = moreswitches(s)))
3319 ;
33b78306 3320 }
95e8664e 3321#ifdef MACOS_TRADITIONAL
e55ac0fa
HS		 3322 /* We are always searching for the #!perl line in MacPerl,
3323 * so if we find it, still keep the line count correct
3324 * by counting lines we already skipped over
3325 */
3326 for (; maclines > 0 ; maclines--)
3327 PerlIO_ungetc(PL_rsfp, '\n');
3328
95e8664e 3329 break;
e55ac0fa
HS		 3330
3331 /* gMacPerl_AlwaysExtract is false in MPW tool */
3332 } else if (gMacPerl_AlwaysExtract) {
3333 ++maclines;
95e8664e 3334#endif
83025b21
LW		 3335 }
3336 }
3337}
3338
afe37c7d 3339
76e3520e 3340STATIC void
cea2e8a9 3341S_init_ids(pTHX)
352d5a3a 3342{
d8eceb89
JH		 3343 PL_uid = PerlProc_getuid();
3344 PL_euid = PerlProc_geteuid();
3345 PL_gid = PerlProc_getgid();
3346 PL_egid = PerlProc_getegid();
748a9306 3347#ifdef VMS
b28d0864
NIS		 3348 PL_uid |= PL_gid << 16;
3349 PL_euid |= PL_egid << 16;
748a9306 3350#endif
3280af22 3351 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
748a9306 3352}
79072805 3353
76e3520e 3354STATIC void
cea2e8a9 3355S_forbid_setid(pTHX_ char *s)
bbce6d69 3356{
3280af22 3357 if (PL_euid != PL_uid)
cea2e8a9 3358 Perl_croak(aTHX_ "No %s allowed while running setuid", s);
3280af22 3359 if (PL_egid != PL_gid)
cea2e8a9 3360 Perl_croak(aTHX_ "No %s allowed while running setgid", s);
bbce6d69 3361}
3362
1ee4443e
IZ		 3363void
3364Perl_init_debugger(pTHX)
748a9306 3365{
1ee4443e
IZ		 3366 HV *ostash = PL_curstash;
3367
3280af22
NIS		 3368 PL_curstash = PL_debstash;
3369 PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
3370 AvREAL_off(PL_dbargs);
3371 PL_DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
3372 PL_DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
3373 PL_DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
1ee4443e 3374 sv_upgrade(GvSV(PL_DBsub), SVt_IV); /* IVX accessed if PERLDB_SUB_NN */
3280af22 3375 PL_DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
ac27b0f5 3376 sv_setiv(PL_DBsingle, 0);
3280af22 3377 PL_DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
ac27b0f5 3378 sv_setiv(PL_DBtrace, 0);
3280af22 3379 PL_DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
ac27b0f5 3380 sv_setiv(PL_DBsignal, 0);
1ee4443e 3381 PL_curstash = ostash;
352d5a3a
LW		 3382}
3383
2ce36478
SM		 3384#ifndef STRESS_REALLOC
3385#define REASONABLE(size) (size)
3386#else
3387#define REASONABLE(size) (1) /* unreasonable */
3388#endif
3389
11343788 3390void
cea2e8a9 3391Perl_init_stacks(pTHX)
79072805 3392{
e336de0d 3393 /* start with 128-item stack and 8K cxstack */
3280af22 3394 PL_curstackinfo = new_stackinfo(REASONABLE(128),
e336de0d 3395 REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
3280af22
NIS		 3396 PL_curstackinfo->si_type = PERLSI_MAIN;
3397 PL_curstack = PL_curstackinfo->si_stack;
3398 PL_mainstack = PL_curstack; /* remember in case we switch stacks */
79072805 3399
3280af22
NIS		 3400 PL_stack_base = AvARRAY(PL_curstack);
3401 PL_stack_sp = PL_stack_base;
3402 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
8990e307 3403
3280af22
NIS		 3404 New(50,PL_tmps_stack,REASONABLE(128),SV*);
3405 PL_tmps_floor = -1;
3406 PL_tmps_ix = -1;
3407 PL_tmps_max = REASONABLE(128);
8990e307 3408
3280af22
NIS		 3409 New(54,PL_markstack,REASONABLE(32),I32);
3410 PL_markstack_ptr = PL_markstack;
3411 PL_markstack_max = PL_markstack + REASONABLE(32);
79072805 3412
ce2f7c3b 3413 SET_MARK_OFFSET;
e336de0d 3414
3280af22
NIS		 3415 New(54,PL_scopestack,REASONABLE(32),I32);
3416 PL_scopestack_ix = 0;
3417 PL_scopestack_max = REASONABLE(32);
79072805 3418
3280af22
NIS		 3419 New(54,PL_savestack,REASONABLE(128),ANY);
3420 PL_savestack_ix = 0;
3421 PL_savestack_max = REASONABLE(128);
79072805 3422
3280af22
NIS		 3423 New(54,PL_retstack,REASONABLE(16),OP*);
3424 PL_retstack_ix = 0;
3425 PL_retstack_max = REASONABLE(16);
378cc40b 3426}
33b78306 3427
2ce36478
SM		 3428#undef REASONABLE
3429
76e3520e 3430STATIC void
cea2e8a9 3431S_nuke_stacks(pTHX)
6e72f9df 3432{
3280af22
NIS		 3433 while (PL_curstackinfo->si_next)
3434 PL_curstackinfo = PL_curstackinfo->si_next;
3435 while (PL_curstackinfo) {
3436 PERL_SI *p = PL_curstackinfo->si_prev;
bac4b2ad 3437 /* curstackinfo->si_stack got nuked by sv_free_arenas() */
3280af22
NIS		 3438 Safefree(PL_curstackinfo->si_cxstack);
3439 Safefree(PL_curstackinfo);
3440 PL_curstackinfo = p;
e336de0d 3441 }
3280af22
NIS		 3442 Safefree(PL_tmps_stack);
3443 Safefree(PL_markstack);
3444 Safefree(PL_scopestack);
3445 Safefree(PL_savestack);
3446 Safefree(PL_retstack);
378cc40b 3447}
33b78306 3448
76e3520e 3449STATIC void
cea2e8a9 3450S_init_lexer(pTHX)
8990e307 3451{
06039172 3452 PerlIO *tmpfp;
3280af22
NIS		 3453 tmpfp = PL_rsfp;
3454 PL_rsfp = Nullfp;
3455 lex_start(PL_linestr);
3456 PL_rsfp = tmpfp;
79cb57f6 3457 PL_subname = newSVpvn("main",4);
8990e307
LW		 3458}
3459
76e3520e 3460STATIC void
cea2e8a9 3461S_init_predump_symbols(pTHX)
45d8adaa 3462{
93a17b20 3463 GV *tmpgv;
af8c498a 3464 IO *io;
79072805 3465
864dbfa3 3466 sv_setpvn(get_sv("\"", TRUE), " ", 1);
3280af22
NIS		 3467 PL_stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
3468 GvMULTI_on(PL_stdingv);
af8c498a 3469 io = GvIOp(PL_stdingv);
a04651f4 3470 IoTYPE(io) = IoTYPE_RDONLY;
af8c498a 3471 IoIFP(io) = PerlIO_stdin();
adbc6bb1 3472 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
a5f75d66 3473 GvMULTI_on(tmpgv);
af8c498a 3474 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
79072805 3475
85e6fe83 3476 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
a5f75d66 3477 GvMULTI_on(tmpgv);
af8c498a 3478 io = GvIOp(tmpgv);
a04651f4 3479 IoTYPE(io) = IoTYPE_WRONLY;
af8c498a 3480 IoOFP(io) = IoIFP(io) = PerlIO_stdout();
4633a7c4 3481 setdefout(tmpgv);
adbc6bb1 3482 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
a5f75d66 3483 GvMULTI_on(tmpgv);
af8c498a 3484 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
79072805 3485
bf49b057
GS		 3486 PL_stderrgv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
3487 GvMULTI_on(PL_stderrgv);
3488 io = GvIOp(PL_stderrgv);
a04651f4 3489 IoTYPE(io) = IoTYPE_WRONLY;
af8c498a 3490 IoOFP(io) = IoIFP(io) = PerlIO_stderr();
adbc6bb1 3491 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
a5f75d66 3492 GvMULTI_on(tmpgv);
af8c498a 3493 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
79072805 3494
3280af22 3495 PL_statname = NEWSV(66,0); /* last filename we did stat on */
ab821d7f 3496
bf4acbe4
GS		 3497 if (PL_osname)
3498 Safefree(PL_osname);
3499 PL_osname = savepv(OSNAME);
79072805 3500}
33b78306 3501
a11ec5a9
RGS		 3502void
3503Perl_init_argv_symbols(pTHX_ register int argc, register char **argv)
33b78306 3504{
79072805 3505 char *s;
79072805 3506 argc--,argv++; /* skip name of script */
3280af22 3507 if (PL_doswitches) {
79072805
LW		 3508 for (; argc > 0 && **argv == '-'; argc--,argv++) {
3509 if (!argv[0][1])
3510 break;
379d538a 3511 if (argv[0][1] == '-' && !argv[0][2]) {
79072805
LW		 3512 argc--,argv++;
3513 break;
3514 }
155aba94 3515 if ((s = strchr(argv[0], '='))) {
79072805 3516 *s++ = '\0';
85e6fe83 3517 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
79072805
LW		 3518 }
3519 else
85e6fe83 3520 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
fe14fcc3 3521 }
79072805 3522 }
a11ec5a9
RGS		 3523 if ((PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV))) {
3524 GvMULTI_on(PL_argvgv);
3525 (void)gv_AVadd(PL_argvgv);
3526 av_clear(GvAVn(PL_argvgv));
3527 for (; argc > 0; argc--,argv++) {
3528 SV *sv = newSVpv(argv[0],0);
3529 av_push(GvAVn(PL_argvgv),sv);
3530 if (PL_widesyscalls)
3531 (void)sv_utf8_decode(sv);
3532 }
3533 }
3534}
3535
04fee9b5
NIS		 3536#ifdef HAS_PROCSELFEXE
3537/* This is a function so that we don't hold on to MAXPATHLEN
8338e367 3538 bytes of stack longer than necessary
04fee9b5
NIS		 3539 */
3540STATIC void
3541S_procself_val(pTHX_ SV *sv, char *arg0)
3542{
3543 char buf[MAXPATHLEN];
d13a6521 3544 int len = readlink(PROCSELFEXE_PATH, buf, sizeof(buf) - 1);
75745e22
TJ		 3545
3546 /* On Playstation2 Linux V1.0 (kernel 2.2.1) readlink(/proc/self/exe)
3547 includes a spurious NUL which will cause $^X to fail in system
3548 or backticks (this will prevent extensions from being built and
3549 many tests from working). readlink is not meant to add a NUL.
3550 Normal readlink works fine.
3551 */
3552 if (len > 0 && buf[len-1] == '\0') {
3553 len--;
3554 }
3555
d103ec31
JH		 3556 /* FreeBSD's implementation is acknowledged to be imperfect, sometimes
3557 returning the text "unknown" from the readlink rather than the path
78cb7c00 3558 to the executable (or returning an error from the readlink). Any valid
d103ec31
JH		 3559 path has a '/' in it somewhere, so use that to validate the result.
3560 See http://www.freebsd.org/cgi/query-pr.cgi?pr=35703
3561 */
78cb7c00 3562 if (len > 0 && memchr(buf, '/', len)) {
04fee9b5
NIS		 3563 sv_setpvn(sv,buf,len);
3564 }
3565 else {
3566 sv_setpv(sv,arg0);
3567 }
3568}
3569#endif /* HAS_PROCSELFEXE */
3570
a11ec5a9
RGS		 3571STATIC void
3572S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
3573{
3574 char *s;
3575 SV *sv;
3576 GV* tmpgv;
a11ec5a9 3577
3280af22
NIS		 3578 PL_toptarget = NEWSV(0,0);
3579 sv_upgrade(PL_toptarget, SVt_PVFM);
3580 sv_setpvn(PL_toptarget, "", 0);
3581 PL_bodytarget = NEWSV(0,0);
3582 sv_upgrade(PL_bodytarget, SVt_PVFM);
3583 sv_setpvn(PL_bodytarget, "", 0);
3584 PL_formtarget = PL_bodytarget;
79072805 3585
bbce6d69 3586 TAINT;
a11ec5a9
RGS		 3587
3588 init_argv_symbols(argc,argv);
3589
155aba94 3590 if ((tmpgv = gv_fetchpv("0",TRUE, SVt_PV))) {
bf4acbe4
GS		 3591#ifdef MACOS_TRADITIONAL
3592 /* $0 is not majick on a Mac */
3593 sv_setpv(GvSV(tmpgv),MacPerl_MPWFileName(PL_origfilename));
3594#else
3280af22 3595 sv_setpv(GvSV(tmpgv),PL_origfilename);
79072805 3596 magicname("0", "0", 1);
bf4acbe4 3597#endif
79072805 3598 }
04fee9b5
NIS		 3599 if ((tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))) {/* $^X */
3600#ifdef HAS_PROCSELFEXE
3601 S_procself_val(aTHX_ GvSV(tmpgv), PL_origargv[0]);
3602#else
8338e367 3603#ifdef OS2
23da6c43 3604 sv_setpv(GvSV(tmpgv), os2_execname(aTHX));
8338e367
JH		 3605#else
3606 sv_setpv(GvSV(tmpgv),PL_origargv[0]);
3607#endif
04fee9b5
NIS		 3608#endif
3609 }
155aba94 3610 if ((PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV))) {
79072805 3611 HV *hv;
3280af22
NIS		 3612 GvMULTI_on(PL_envgv);
3613 hv = GvHVn(PL_envgv);
14befaf4 3614 hv_magic(hv, Nullgv, PERL_MAGIC_env);
fa6a1c44 3615#ifdef USE_ENVIRON_ARRAY
4633a7c4
LW		 3616 /* Note that if the supplied env parameter is actually a copy
3617 of the global environ then it may now point to free'd memory
3618 if the environment has been modified since. To avoid this
3619 problem we treat env==NULL as meaning 'use the default'
3620 */
3621 if (!env)
3622 env = environ;
4efc5df6
GS		 3623 if (env != environ
3624# ifdef USE_ITHREADS
3625 && PL_curinterp == aTHX
3626# endif
3627 )
3628 {
79072805 3629 environ[0] = Nullch;
4efc5df6 3630 }
764df951
IZ		 3631 if (env)
3632 for (; *env; env++) {
93a17b20 3633 if (!(s = strchr(*env,'=')))
79072805 3634 continue;
60ce6247 3635#if defined(MSDOS)
61968511 3636 *s = '\0';
137443ea 3637 (void)strupr(*env);
61968511 3638 *s = '=';
137443ea 3639#endif
61968511 3640 sv = newSVpv(s+1, 0);
79072805 3641 (void)hv_store(hv, *env, s - *env, sv, 0);
61968511
GA		 3642 if (env != environ)
3643 mg_set(sv);
764df951 3644 }
103a7189 3645#endif /* USE_ENVIRON_ARRAY */
79072805 3646 }
bbce6d69 3647 TAINT_NOT;
306196c3
MS		 3648 if ((tmpgv = gv_fetchpv("$",TRUE, SVt_PV))) {
3649 SvREADONLY_off(GvSV(tmpgv));
7766f137 3650 sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
306196c3
MS		 3651 SvREADONLY_on(GvSV(tmpgv));
3652 }
4d76a344
RGS		 3653#ifdef THREADS_HAVE_PIDS
3654 PL_ppid = (IV)getppid();
3655#endif
2710853f
MJD		 3656
3657 /* touch @F array to prevent spurious warnings 20020415 MJD */
3658 if (PL_minus_a) {
3659 (void) get_av("main::F", TRUE | GV_ADDMULTI);
3660 }
3661 /* touch @- and @+ arrays to prevent spurious warnings 20020415 MJD */
3662 (void) get_av("main::-", TRUE | GV_ADDMULTI);
3663 (void) get_av("main::+", TRUE | GV_ADDMULTI);
33b78306 3664}
34de22dd 3665
76e3520e 3666STATIC void
cea2e8a9 3667S_init_perllib(pTHX)
34de22dd 3668{
85e6fe83 3669 char *s;
3280af22 3670 if (!PL_tainting) {
552a7a9b 3671#ifndef VMS
76e3520e 3672 s = PerlEnv_getenv("PERL5LIB");
85e6fe83 3673 if (s)
9c8a64f0 3674 incpush(s, TRUE, TRUE);
85e6fe83 3675 else
9c8a64f0 3676 incpush(PerlEnv_getenv("PERLLIB"), FALSE, FALSE);
552a7a9b 3677#else /* VMS */
3678 /* Treat PERL5?LIB as a possible search list logical name -- the
3679 * "natural" VMS idiom for a Unix path string. We allow each
3680 * element to be a set of |-separated directories for compatibility.
3681 */
3682 char buf[256];
3683 int idx = 0;
3684 if (my_trnlnm("PERL5LIB",buf,0))
9c8a64f0 3685 do { incpush(buf,TRUE,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
552a7a9b 3686 else
9c8a64f0 3687 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE,FALSE);
552a7a9b 3688#endif /* VMS */
85e6fe83 3689 }
34de22dd 3690
c90c0ff4 3691/* Use the ~-expanded versions of APPLLIB (undocumented),
65f19062 3692 ARCHLIB PRIVLIB SITEARCH SITELIB VENDORARCH and VENDORLIB
df5cef82 3693*/
4633a7c4 3694#ifdef APPLLIB_EXP
9c8a64f0 3695 incpush(APPLLIB_EXP, TRUE, TRUE);
16d20bd9 3696#endif
4633a7c4 3697
fed7345c 3698#ifdef ARCHLIB_EXP
9c8a64f0 3699 incpush(ARCHLIB_EXP, FALSE, FALSE);
a0d0e21e 3700#endif
bf4acbe4
GS		 3701#ifdef MACOS_TRADITIONAL
3702 {
c623ac67 3703 Stat_t tmpstatbuf;
bf4acbe4
GS		 3704 SV * privdir = NEWSV(55, 0);
3705 char * macperl = PerlEnv_getenv("MACPERL");
3706
3707 if (!macperl)
3708 macperl = "";
3709
3710 Perl_sv_setpvf(aTHX_ privdir, "%slib:", macperl);
3711 if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode))
3712 incpush(SvPVX(privdir), TRUE, FALSE);
3713 Perl_sv_setpvf(aTHX_ privdir, "%ssite_perl:", macperl);
3714 if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode))
3715 incpush(SvPVX(privdir), TRUE, FALSE);
ac27b0f5 3716
bf4acbe4
GS		 3717 SvREFCNT_dec(privdir);
3718 }
3719 if (!PL_tainting)
3720 incpush(":", FALSE, FALSE);
3721#else
fed7345c 3722#ifndef PRIVLIB_EXP
65f19062 3723# define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
34de22dd 3724#endif
ac27b0f5 3725#if defined(WIN32)
9c8a64f0 3726 incpush(PRIVLIB_EXP, TRUE, FALSE);
00dc2f4f 3727#else
9c8a64f0 3728 incpush(PRIVLIB_EXP, FALSE, FALSE);
00dc2f4f 3729#endif
4633a7c4 3730
65f19062 3731#ifdef SITEARCH_EXP
3b290362
GS		 3732 /* sitearch is always relative to sitelib on Windows for
3733 * DLL-based path intuition to work correctly */
3734# if !defined(WIN32)
9c8a64f0 3735 incpush(SITEARCH_EXP, FALSE, FALSE);
65f19062
GS		 3736# endif
3737#endif
3738
4633a7c4 3739#ifdef SITELIB_EXP
65f19062 3740# if defined(WIN32)
9c8a64f0 3741 incpush(SITELIB_EXP, TRUE, FALSE); /* this picks up sitearch as well */
65f19062 3742# else
9c8a64f0 3743 incpush(SITELIB_EXP, FALSE, FALSE);
65f19062
GS		 3744# endif
3745#endif
189d1e8d 3746
65f19062 3747#ifdef SITELIB_STEM /* Search for version-specific dirs below here */
9c8a64f0 3748 incpush(SITELIB_STEM, FALSE, TRUE);
81c6dfba 3749#endif
65f19062
GS		 3750
3751#ifdef PERL_VENDORARCH_EXP
4ea817c6 3752 /* vendorarch is always relative to vendorlib on Windows for
3b290362
GS		 3753 * DLL-based path intuition to work correctly */
3754# if !defined(WIN32)
9c8a64f0 3755 incpush(PERL_VENDORARCH_EXP, FALSE, FALSE);
65f19062 3756# endif
4b03c463 3757#endif
65f19062
GS		 3758
3759#ifdef PERL_VENDORLIB_EXP
3760# if defined(WIN32)
9c8a64f0 3761 incpush(PERL_VENDORLIB_EXP, TRUE, FALSE); /* this picks up vendorarch as well */
65f19062 3762# else
9c8a64f0 3763 incpush(PERL_VENDORLIB_EXP, FALSE, FALSE);
65f19062 3764# endif
a3635516 3765#endif
65f19062
GS		 3766
3767#ifdef PERL_VENDORLIB_STEM /* Search for version-specific dirs below here */
9c8a64f0 3768 incpush(PERL_VENDORLIB_STEM, FALSE, TRUE);
00dc2f4f 3769#endif
65f19062 3770
3b777bb4
GS		 3771#ifdef PERL_OTHERLIBDIRS
3772 incpush(PERL_OTHERLIBDIRS, TRUE, TRUE);
3773#endif
3774
3280af22 3775 if (!PL_tainting)
9c8a64f0 3776 incpush(".", FALSE, FALSE);
bf4acbe4 3777#endif /* MACOS_TRADITIONAL */
774d564b 3778}
3779
ed79a026 3780#if defined(DOSISH) || defined(EPOC)
774d564b 3781# define PERLLIB_SEP ';'
3782#else
3783# if defined(VMS)
3784# define PERLLIB_SEP '|'
3785# else
bf4acbe4
GS		 3786# if defined(MACOS_TRADITIONAL)
3787# define PERLLIB_SEP ','
3788# else
3789# define PERLLIB_SEP ':'
3790# endif
774d564b 3791# endif
3792#endif
3793#ifndef PERLLIB_MANGLE
3794# define PERLLIB_MANGLE(s,n) (s)
ac27b0f5 3795#endif
774d564b 3796
76e3520e 3797STATIC void
9c8a64f0 3798S_incpush(pTHX_ char *p, int addsubdirs, int addoldvers)
774d564b 3799{
3800 SV *subdir = Nullsv;
774d564b 3801
3b290362 3802 if (!p || !*p)
774d564b 3803 return;
3804
9c8a64f0 3805 if (addsubdirs || addoldvers) {
00db4c45 3806 subdir = sv_newmortal();
774d564b 3807 }
3808
3809 /* Break at all separators */
3810 while (p && *p) {
8c52afec 3811 SV *libdir = NEWSV(55,0);
774d564b 3812 char *s;
3813
3814 /* skip any consecutive separators */
3815 while ( *p == PERLLIB_SEP ) {
3816 /* Uncomment the next line for PATH semantics */
79cb57f6 3817 /* av_push(GvAVn(PL_incgv), newSVpvn(".", 1)); */
774d564b 3818 p++;
3819 }
3820
3821 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
3822 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
3823 (STRLEN)(s - p));
3824 p = s + 1;
3825 }
3826 else {
3827 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
3828 p = Nullch; /* break out */
3829 }
bf4acbe4 3830#ifdef MACOS_TRADITIONAL
e69a2255
JH		 3831 if (!strchr(SvPVX(libdir), ':')) {
3832 char buf[256];
3833
3834 sv_setpv(libdir, MacPerl_CanonDir(SvPVX(libdir), buf, 0));
3835 }
bf4acbe4
GS		 3836 if (SvPVX(libdir)[SvCUR(libdir)-1] != ':')
3837 sv_catpv(libdir, ":");
3838#endif
774d564b 3839
3840 /*
3841 * BEFORE pushing libdir onto @INC we may first push version- and
3842 * archname-specific sub-directories.
3843 */
9c8a64f0 3844 if (addsubdirs || addoldvers) {
29d82f8d 3845#ifdef PERL_INC_VERSION_LIST
8353b874
GS		 3846 /* Configure terminates PERL_INC_VERSION_LIST with a NULL */
3847 const char *incverlist[] = { PERL_INC_VERSION_LIST };
29d82f8d
GS		 3848 const char **incver;
3849#endif
c623ac67 3850 Stat_t tmpstatbuf;
aa689395 3851#ifdef VMS
3852 char *unix;
3853 STRLEN len;
774d564b 3854
2d8e6c8d 3855 if ((unix = tounixspec_ts(SvPV(libdir,len),Nullch)) != Nullch) {
aa689395 3856 len = strlen(unix);
3857 while (unix[len-1] == '/') len--; /* Cosmetic */
3858 sv_usepvn(libdir,unix,len);
3859 }
3860 else
bf49b057 3861 PerlIO_printf(Perl_error_log,
aa689395 3862 "Failed to unixify @INC element \"%s\"\n",
2d8e6c8d 3863 SvPV(libdir,len));
aa689395 3864#endif
9c8a64f0 3865 if (addsubdirs) {
bf4acbe4
GS		 3866#ifdef MACOS_TRADITIONAL
3867#define PERL_AV_SUFFIX_FMT ""
084592ab
CN		 3868#define PERL_ARCH_FMT "%s:"
3869#define PERL_ARCH_FMT_PATH PERL_FS_VER_FMT PERL_AV_SUFFIX_FMT
bf4acbe4
GS		 3870#else
3871#define PERL_AV_SUFFIX_FMT "/"
3872#define PERL_ARCH_FMT "/%s"
084592ab 3873#define PERL_ARCH_FMT_PATH PERL_AV_SUFFIX_FMT PERL_FS_VER_FMT
bf4acbe4 3874#endif
9c8a64f0 3875 /* .../version/archname if -d .../version/archname */
084592ab 3876 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH PERL_ARCH_FMT,
9c8a64f0
GS		 3877 libdir,
3878 (int)PERL_REVISION, (int)PERL_VERSION,
3879 (int)PERL_SUBVERSION, ARCHNAME);
3880 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3881 S_ISDIR(tmpstatbuf.st_mode))
3882 av_push(GvAVn(PL_incgv), newSVsv(subdir));
4b03c463 3883
9c8a64f0 3884 /* .../version if -d .../version */
084592ab 3885 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH, libdir,
9c8a64f0
GS		 3886 (int)PERL_REVISION, (int)PERL_VERSION,
3887 (int)PERL_SUBVERSION);
3888 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3889 S_ISDIR(tmpstatbuf.st_mode))
3890 av_push(GvAVn(PL_incgv), newSVsv(subdir));
3891
3892 /* .../archname if -d .../archname */
bf4acbe4 3893 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, libdir, ARCHNAME);
29d82f8d
GS		 3894 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3895 S_ISDIR(tmpstatbuf.st_mode))
3896 av_push(GvAVn(PL_incgv), newSVsv(subdir));
29d82f8d 3897 }
9c8a64f0 3898
9c8a64f0 3899#ifdef PERL_INC_VERSION_LIST
ccc2aad8 3900 if (addoldvers) {
9c8a64f0
GS		 3901 for (incver = incverlist; *incver; incver++) {
3902 /* .../xxx if -d .../xxx */
bf4acbe4 3903 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, libdir, *incver);
9c8a64f0
GS		 3904 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3905 S_ISDIR(tmpstatbuf.st_mode))
3906 av_push(GvAVn(PL_incgv), newSVsv(subdir));
3907 }
3908 }
29d82f8d 3909#endif
774d564b 3910 }
3911
3912 /* finally push this lib directory on the end of @INC */
3280af22 3913 av_push(GvAVn(PL_incgv), libdir);
774d564b 3914 }
34de22dd 3915}
93a17b20 3916
4d1ff10f 3917#ifdef USE_5005THREADS
76e3520e 3918STATIC struct perl_thread *
cea2e8a9 3919S_init_main_thread(pTHX)
199100c8 3920{
c5be433b 3921#if !defined(PERL_IMPLICIT_CONTEXT)
52e1cb5e 3922 struct perl_thread *thr;
cea2e8a9 3923#endif
199100c8
MB		 3924 XPV *xpv;
3925
52e1cb5e 3926 Newz(53, thr, 1, struct perl_thread);
533c011a 3927 PL_curcop = &PL_compiling;
c5be433b 3928 thr->interp = PERL_GET_INTERP;
199100c8 3929 thr->cvcache = newHV();
54b9620d 3930 thr->threadsv = newAV();
940cb80d 3931 /* thr->threadsvp is set when find_threadsv is called */
199100c8
MB		 3932 thr->specific = newAV();
3933 thr->flags = THRf_R_JOINABLE;
3934 MUTEX_INIT(&thr->mutex);
3935 /* Handcraft thrsv similarly to mess_sv */
533c011a 3936 New(53, PL_thrsv, 1, SV);
199100c8 3937 Newz(53, xpv, 1, XPV);
533c011a
NIS		 3938 SvFLAGS(PL_thrsv) = SVt_PV;
3939 SvANY(PL_thrsv) = (void*)xpv;
3940 SvREFCNT(PL_thrsv) = 1 << 30; /* practically infinite */
3941 SvPVX(PL_thrsv) = (char*)thr;
3942 SvCUR_set(PL_thrsv, sizeof(thr));
3943 SvLEN_set(PL_thrsv, sizeof(thr));
3944 *SvEND(PL_thrsv) = '\0'; /* in the trailing_nul field */
3945 thr->oursv = PL_thrsv;
3946 PL_chopset = " \n-";
3967c732 3947 PL_dumpindent = 4;
533c011a
NIS		 3948
3949 MUTEX_LOCK(&PL_threads_mutex);
3950 PL_nthreads++;
199100c8
MB		 3951 thr->tid = 0;
3952 thr->next = thr;
3953 thr->prev = thr;
8dcd6f7b 3954 thr->thr_done = 0;
533c011a 3955 MUTEX_UNLOCK(&PL_threads_mutex);
199100c8 3956
4b026b9e 3957#ifdef HAVE_THREAD_INTERN
4f63d024 3958 Perl_init_thread_intern(thr);
235db74f
GS		 3959#endif
3960
3961#ifdef SET_THREAD_SELF
3962 SET_THREAD_SELF(thr);
199100c8
MB		 3963#else
3964 thr->self = pthread_self();
235db74f 3965#endif /* SET_THREAD_SELF */
06d86050 3966 PERL_SET_THX(thr);
199100c8
MB		 3967
3968 /*
411caa50
JH		 3969 * These must come after the thread self setting
3970 * because sv_setpvn does SvTAINT and the taint
3971 * fields thread selfness being set.
199100c8 3972 */
533c011a
NIS		 3973 PL_toptarget = NEWSV(0,0);
3974 sv_upgrade(PL_toptarget, SVt_PVFM);
3975 sv_setpvn(PL_toptarget, "", 0);
3976 PL_bodytarget = NEWSV(0,0);
3977 sv_upgrade(PL_bodytarget, SVt_PVFM);
3978 sv_setpvn(PL_bodytarget, "", 0);
3979 PL_formtarget = PL_bodytarget;
79cb57f6 3980 thr->errsv = newSVpvn("", 0);
78857c3c 3981 (void) find_threadsv("@"); /* Ensure $@ is initialised early */
5c0ca799 3982
533c011a 3983 PL_maxscream = -1;
a2efc822 3984 PL_peepp = MEMBER_TO_FPTR(Perl_peep);
0b94c7bb
GS		 3985 PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp);
3986 PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags);
3987 PL_regint_start = MEMBER_TO_FPTR(Perl_re_intuit_start);
3988 PL_regint_string = MEMBER_TO_FPTR(Perl_re_intuit_string);
3989 PL_regfree = MEMBER_TO_FPTR(Perl_pregfree);
533c011a
NIS		 3990 PL_regindent = 0;
3991 PL_reginterp_cnt = 0;
5c0ca799 3992
199100c8
MB		 3993 return thr;
3994}
4d1ff10f 3995#endif /* USE_5005THREADS */
199100c8 3996
93a17b20 3997void
864dbfa3 3998Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
93a17b20 3999{
971a9dd3 4000 SV *atsv;
57843af0 4001 line_t oldline = CopLINE(PL_curcop);
312caa8e 4002 CV *cv;
22921e25 4003 STRLEN len;
6224f72b 4004 int ret;
db36c5a1 4005 dJMPENV;
93a17b20 4006
76e3520e 4007 while (AvFILL(paramList) >= 0) {
312caa8e 4008 cv = (CV*)av_shift(paramList);
ece599bd
RGS		 4009 if (PL_savebegin) {
4010 if (paramList == PL_beginav) {
059a8bb7 4011 /* save PL_beginav for compiler */
ece599bd
RGS		 4012 if (! PL_beginav_save)
4013 PL_beginav_save = newAV();
4014 av_push(PL_beginav_save, (SV*)cv);
4015 }
4016 else if (paramList == PL_checkav) {
4017 /* save PL_checkav for compiler */
4018 if (! PL_checkav_save)
4019 PL_checkav_save = newAV();
4020 av_push(PL_checkav_save, (SV*)cv);
4021 }
059a8bb7
JH		 4022 } else {
4023 SAVEFREESV(cv);
4024 }
14dd3ad8
GS		 4025#ifdef PERL_FLEXIBLE_EXCEPTIONS
4026 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_list_body), cv);
4027#else
4028 JMPENV_PUSH(ret);
4029#endif
6224f72b 4030 switch (ret) {
312caa8e 4031 case 0:
14dd3ad8
GS		 4032#ifndef PERL_FLEXIBLE_EXCEPTIONS
4033 call_list_body(cv);
4034#endif
971a9dd3 4035 atsv = ERRSV;
312caa8e
CS		 4036 (void)SvPV(atsv, len);
4037 if (len) {
971a9dd3 4038 STRLEN n_a;
312caa8e 4039 PL_curcop = &PL_compiling;
57843af0 4040 CopLINE_set(PL_curcop, oldline);
312caa8e
CS		 4041 if (paramList == PL_beginav)
4042 sv_catpv(atsv, "BEGIN failed--compilation aborted");
4043 else
4f25aa18
GS		 4044 Perl_sv_catpvf(aTHX_ atsv,
4045 "%s failed--call queue aborted",
7d30b5c4 4046 paramList == PL_checkav ? "CHECK"
4f25aa18
GS		 4047 : paramList == PL_initav ? "INIT"
4048 : "END");
312caa8e
CS		 4049 while (PL_scopestack_ix > oldscope)
4050 LEAVE;
14dd3ad8 4051 JMPENV_POP;
971a9dd3 4052 Perl_croak(aTHX_ "%s", SvPVx(atsv, n_a));
a0d0e21e 4053 }
85e6fe83 4054 break;
6224f72b 4055 case 1:
f86702cc 4056 STATUS_ALL_FAILURE;
85e6fe83 4057 /* FALL THROUGH */
6224f72b 4058 case 2:
85e6fe83 4059 /* my_exit() was called */
3280af22 4060 while (PL_scopestack_ix > oldscope)
2ae324a7 4061 LEAVE;
84902520 4062 FREETMPS;
3280af22 4063 PL_curstash = PL_defstash;
3280af22 4064 PL_curcop = &PL_compiling;
57843af0 4065 CopLINE_set(PL_curcop, oldline);
14dd3ad8 4066 JMPENV_POP;
cc3604b1 4067 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED)) {
3280af22 4068 if (paramList == PL_beginav)
cea2e8a9 4069 Perl_croak(aTHX_ "BEGIN failed--compilation aborted");
85e6fe83 4070 else
4f25aa18 4071 Perl_croak(aTHX_ "%s failed--call queue aborted",
7d30b5c4 4072 paramList == PL_checkav ? "CHECK"
4f25aa18
GS		 4073 : paramList == PL_initav ? "INIT"
4074 : "END");
85e6fe83 4075 }
f86702cc 4076 my_exit_jump();
85e6fe83 4077 /* NOTREACHED */
6224f72b 4078 case 3:
312caa8e
CS		 4079 if (PL_restartop) {
4080 PL_curcop = &PL_compiling;
57843af0 4081 CopLINE_set(PL_curcop, oldline);
312caa8e 4082 JMPENV_JUMP(3);
85e6fe83 4083 }
bf49b057 4084 PerlIO_printf(Perl_error_log, "panic: restartop\n");
312caa8e
CS		 4085 FREETMPS;
4086 break;
8990e307 4087 }
14dd3ad8 4088 JMPENV_POP;
93a17b20 4089 }
93a17b20 4090}
93a17b20 4091
14dd3ad8 4092#ifdef PERL_FLEXIBLE_EXCEPTIONS
312caa8e 4093STATIC void *
14dd3ad8 4094S_vcall_list_body(pTHX_ va_list args)
312caa8e 4095{
312caa8e 4096 CV *cv = va_arg(args, CV*);
14dd3ad8
GS		 4097 return call_list_body(cv);
4098}
4099#endif
312caa8e 4100
14dd3ad8
GS		 4101STATIC void *
4102S_call_list_body(pTHX_ CV *cv)
4103{
312caa8e 4104 PUSHMARK(PL_stack_sp);
864dbfa3 4105 call_sv((SV*)cv, G_EVAL|G_DISCARD);
312caa8e
CS		 4106 return NULL;
4107}
4108
f86702cc 4109void
864dbfa3 4110Perl_my_exit(pTHX_ U32 status)
f86702cc 4111{
8b73bbec 4112 DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
a863c7d1 4113 thr, (unsigned long) status));
f86702cc 4114 switch (status) {
4115 case 0:
4116 STATUS_ALL_SUCCESS;
4117 break;
4118 case 1:
4119 STATUS_ALL_FAILURE;
4120 break;
4121 default:
4122 STATUS_NATIVE_SET(status);
4123 break;
4124 }
4125 my_exit_jump();
4126}
4127
4128void
864dbfa3 4129Perl_my_failure_exit(pTHX)
f86702cc 4130{
4131#ifdef VMS
4132 if (vaxc$errno & 1) {
4fdae800 4133 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
4134 STATUS_NATIVE_SET(44);
f86702cc 4135 }
4136 else {
ff0cee69 4137 if (!vaxc$errno && errno) /* unlikely */
4fdae800 4138 STATUS_NATIVE_SET(44);
f86702cc 4139 else
4fdae800 4140 STATUS_NATIVE_SET(vaxc$errno);
f86702cc 4141 }
4142#else
9b599b2a 4143 int exitstatus;
f86702cc 4144 if (errno & 255)
4145 STATUS_POSIX_SET(errno);
9b599b2a 4146 else {
ac27b0f5 4147 exitstatus = STATUS_POSIX >> 8;
9b599b2a
GS		 4148 if (exitstatus & 255)
4149 STATUS_POSIX_SET(exitstatus);
4150 else
4151 STATUS_POSIX_SET(255);
4152 }
f86702cc 4153#endif
4154 my_exit_jump();
93a17b20
LW		 4155}
4156
76e3520e 4157STATIC void
cea2e8a9 4158S_my_exit_jump(pTHX)
f86702cc 4159{
c09156bb 4160 register PERL_CONTEXT *cx;
f86702cc 4161 I32 gimme;
4162 SV **newsp;
4163
3280af22
NIS		 4164 if (PL_e_script) {
4165 SvREFCNT_dec(PL_e_script);
4166 PL_e_script = Nullsv;
f86702cc 4167 }
4168
3280af22 4169 POPSTACK_TO(PL_mainstack);
f86702cc 4170 if (cxstack_ix >= 0) {
4171 if (cxstack_ix > 0)
4172 dounwind(0);
3280af22 4173 POPBLOCK(cx,PL_curpm);
f86702cc 4174 LEAVE;
4175 }
ff0cee69 4176
6224f72b 4177 JMPENV_JUMP(2);
f86702cc 4178}
873ef191 4179
0cb96387 4180static I32
acfe0abc 4181read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen)
873ef191
GS		 4182{
4183 char *p, *nl;
3280af22 4184 p = SvPVX(PL_e_script);
873ef191 4185 nl = strchr(p, '\n');
3280af22 4186 nl = (nl) ? nl+1 : SvEND(PL_e_script);
7dfe3f66 4187 if (nl-p == 0) {
0cb96387 4188 filter_del(read_e_script);
873ef191 4189 return 0;
7dfe3f66 4190 }
873ef191 4191 sv_catpvn(buf_sv, p, nl-p);
3280af22 4192 sv_chop(PL_e_script, nl);
873ef191
GS		 4193 return 1;
4194}
Unnamed repository; edit this file 'description' to name the repository.