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