This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
https://perl5.git.perl.org / perl5.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Integrate
[perl5.git] / perl.c
CommitLineData
a0d0e21e
LW		 1/* perl.c
2 *
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
5b7ea690
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
5b7ea690
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);
5b7ea690 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;
5b7ea690 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"))
5b7ea690 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:
5b7ea690 1344 sv_setsv(get_sv("/", TRUE), PL_rs);
54310121 1345
f675dbe5
CB		 1346 if (
1347#ifndef SECURE_INTERNAL_GETENV
1348 !PL_tainting &&
1349#endif
cf756827 1350 (s = PerlEnv_getenv("PERL5OPT")))
0df16ed7 1351 {
cf756827 1352 char *popt = s;
74288ac8
GS		 1353 while (isSPACE(*s))
1354 s++;
317ea90d 1355 if (*s == '-' && *(s+1) == 'T') {
74288ac8 1356 PL_tainting = TRUE;
317ea90d
MS		 1357 PL_taint_warn = FALSE;
1358 }
74288ac8 1359 else {
cf756827 1360 char *popt_copy = Nullch;
74288ac8 1361 while (s && *s) {
4ea8f8fb 1362 char *d;
74288ac8
GS		 1363 while (isSPACE(*s))
1364 s++;
1365 if (*s == '-') {
1366 s++;
1367 if (isSPACE(*s))
1368 continue;
1369 }
4ea8f8fb 1370 d = s;
74288ac8
GS		 1371 if (!*s)
1372 break;
1c4db469 1373 if (!strchr("DIMUdmtw", *s))
cea2e8a9 1374 Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s);
4ea8f8fb
MS		 1375 while (++s && *s) {
1376 if (isSPACE(*s)) {
cf756827
GS		 1377 if (!popt_copy) {
1378 popt_copy = SvPVX(sv_2mortal(newSVpv(popt,0)));
1379 s = popt_copy + (s - popt);
1380 d = popt_copy + (d - popt);
1381 }
4ea8f8fb
MS		 1382 *s++ = '\0';
1383 break;
1384 }
1385 }
1c4db469 1386 if (*d == 't') {
317ea90d
MS		 1387 if( !PL_tainting ) {
1388 PL_taint_warn = TRUE;
1389 PL_tainting = TRUE;
1390 }
1c4db469
RGS		 1391 } else {
1392 moreswitches(d);
1393 }
6224f72b 1394 }
6224f72b
GS		 1395 }
1396 }
a0d0e21e 1397
317ea90d
MS		 1398 if (PL_taint_warn && PL_dowarn != G_WARN_ALL_OFF) {
1399 PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
1400 }
1401
6224f72b
GS		 1402 if (!scriptname)
1403 scriptname = argv[0];
3280af22 1404 if (PL_e_script) {
6224f72b
GS		 1405 argc++,argv--;
1406 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
1407 }
1408 else if (scriptname == Nullch) {
1409#ifdef MSDOS
1410 if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
1411 moreswitches("h");
1412#endif
1413 scriptname = "-";
1414 }
1415
1416 init_perllib();
1417
1418 open_script(scriptname,dosearch,sv,&fdscript);
1419
1420 validate_suid(validarg, scriptname,fdscript);
1421
64ca3a65 1422#ifndef PERL_MICRO
0b5b802d
GS		 1423#if defined(SIGCHLD) || defined(SIGCLD)
1424 {
1425#ifndef SIGCHLD
1426# define SIGCHLD SIGCLD
1427#endif
1428 Sighandler_t sigstate = rsignal_state(SIGCHLD);
1429 if (sigstate == SIG_IGN) {
1430 if (ckWARN(WARN_SIGNAL))
9014280d 1431 Perl_warner(aTHX_ packWARN(WARN_SIGNAL),
0b5b802d
GS		 1432 "Can't ignore signal CHLD, forcing to default");
1433 (void)rsignal(SIGCHLD, (Sighandler_t)SIG_DFL);
1434 }
1435 }
1436#endif
64ca3a65 1437#endif
0b5b802d 1438
bf4acbe4
GS		 1439#ifdef MACOS_TRADITIONAL
1440 if (PL_doextract || gMacPerl_AlwaysExtract) {
1441#else
f4c556ac 1442 if (PL_doextract) {
bf4acbe4 1443#endif
6224f72b 1444 find_beginning();
f4c556ac
GS		 1445 if (cddir && PerlDir_chdir(cddir) < 0)
1446 Perl_croak(aTHX_ "Can't chdir to %s",cddir);
1447
1448 }
6224f72b 1449
3280af22
NIS		 1450 PL_main_cv = PL_compcv = (CV*)NEWSV(1104,0);
1451 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
1452 CvUNIQUE_on(PL_compcv);
1453
1454 PL_comppad = newAV();
1455 av_push(PL_comppad, Nullsv);
1456 PL_curpad = AvARRAY(PL_comppad);
1457 PL_comppad_name = newAV();
1458 PL_comppad_name_fill = 0;
1459 PL_min_intro_pending = 0;
1460 PL_padix = 0;
4d1ff10f 1461#ifdef USE_5005THREADS
79cb57f6 1462 av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
533c011a
NIS		 1463 PL_curpad[0] = (SV*)newAV();
1464 SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
1465 CvOWNER(PL_compcv) = 0;
1466 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
1467 MUTEX_INIT(CvMUTEXP(PL_compcv));
4d1ff10f 1468#endif /* USE_5005THREADS */
6224f72b
GS		 1469
1470 comppadlist = newAV();
1471 AvREAL_off(comppadlist);
3280af22
NIS		 1472 av_store(comppadlist, 0, (SV*)PL_comppad_name);
1473 av_store(comppadlist, 1, (SV*)PL_comppad);
1474 CvPADLIST(PL_compcv) = comppadlist;
6224f72b 1475
0c4f7ff0 1476 boot_core_PerlIO();
6224f72b 1477 boot_core_UNIVERSAL();
9a34ef1d 1478#ifndef PERL_MICRO
09bef843 1479 boot_core_xsutils();
9a34ef1d 1480#endif
6224f72b
GS		 1481
1482 if (xsinit)
acfe0abc 1483 (*xsinit)(aTHX); /* in case linked C routines want magical variables */
64ca3a65 1484#ifndef PERL_MICRO
ed79a026 1485#if defined(VMS) || defined(WIN32) || defined(DJGPP) || defined(__CYGWIN__) || defined(EPOC)
c5be433b 1486 init_os_extras();
6224f72b 1487#endif
64ca3a65 1488#endif
6224f72b 1489
29209bc5 1490#ifdef USE_SOCKS
1b9c9cf5
DH		 1491# ifdef HAS_SOCKS5_INIT
1492 socks5_init(argv[0]);
1493# else
29209bc5 1494 SOCKSinit(argv[0]);
1b9c9cf5 1495# endif
ac27b0f5 1496#endif
29209bc5 1497
6224f72b
GS		 1498 init_predump_symbols();
1499 /* init_postdump_symbols not currently designed to be called */
1500 /* more than once (ENV isn't cleared first, for example) */
1501 /* But running with -u leaves %ENV & @ARGV undefined! XXX */
3280af22 1502 if (!PL_do_undump)
6224f72b
GS		 1503 init_postdump_symbols(argc,argv,env);
1504
085a54d9
JH		 1505 /* PL_wantutf8 is conditionally turned on by
1506 * locale.c:Perl_init_i18nl10n() if the environment
1507 * look like the user wants to use UTF-8. */
b310b053
JH		 1508 if (PL_wantutf8) { /* Requires init_predump_symbols(). */
1509 IO* io;
1510 PerlIO* fp;
1511 SV* sv;
085a54d9
JH		 1512 /* Turn on UTF-8-ness on STDIN, STDOUT, STDERR
1513 * _and_ the default open discipline. */
b310b053
JH		 1514 if (PL_stdingv && (io = GvIO(PL_stdingv)) && (fp = IoIFP(io)))
1515 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
1516 if (PL_defoutgv && (io = GvIO(PL_defoutgv)) && (fp = IoOFP(io)))
1517 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
1518 if (PL_stderrgv && (io = GvIO(PL_stderrgv)) && (fp = IoOFP(io)))
1519 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
1520 if ((sv = GvSV(gv_fetchpv("\017PEN", TRUE, SVt_PV)))) {
1521 sv_setpvn(sv, ":utf8\0:utf8", 11);
1522 SvSETMAGIC(sv);
1523 }
1524 }
1525
6224f72b
GS		 1526 init_lexer();
1527
1528 /* now parse the script */
1529
5b7ea690 1530 SETERRNO(0,SS_NORMAL);
3280af22 1531 PL_error_count = 0;
bf4acbe4
GS		 1532#ifdef MACOS_TRADITIONAL
1533 if (gMacPerl_SyntaxError = (yyparse() || PL_error_count)) {
1534 if (PL_minus_c)
1535 Perl_croak(aTHX_ "%s had compilation errors.\n", MacPerl_MPWFileName(PL_origfilename));
1536 else {
1537 Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
1538 MacPerl_MPWFileName(PL_origfilename));
1539 }
1540 }
1541#else
3280af22
NIS		 1542 if (yyparse() || PL_error_count) {
1543 if (PL_minus_c)
cea2e8a9 1544 Perl_croak(aTHX_ "%s had compilation errors.\n", PL_origfilename);
6224f72b 1545 else {
cea2e8a9 1546 Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
097ee67d 1547 PL_origfilename);
6224f72b
GS		 1548 }
1549 }
bf4acbe4 1550#endif
57843af0 1551 CopLINE_set(PL_curcop, 0);
3280af22
NIS		 1552 PL_curstash = PL_defstash;
1553 PL_preprocess = FALSE;
1554 if (PL_e_script) {
1555 SvREFCNT_dec(PL_e_script);
1556 PL_e_script = Nullsv;
6224f72b
GS		 1557 }
1558
3280af22 1559 if (PL_do_undump)
6224f72b
GS		 1560 my_unexec();
1561
57843af0
GS		 1562 if (isWARN_ONCE) {
1563 SAVECOPFILE(PL_curcop);
1564 SAVECOPLINE(PL_curcop);
3280af22 1565 gv_check(PL_defstash);
57843af0 1566 }
6224f72b
GS		 1567
1568 LEAVE;
1569 FREETMPS;
1570
1571#ifdef MYMALLOC
1572 if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
1573 dump_mstats("after compilation:");
1574#endif
1575
1576 ENTER;
3280af22 1577 PL_restartop = 0;
312caa8e 1578 return NULL;
6224f72b
GS		 1579}
1580
954c1994
GS		 1581/*
1582=for apidoc perl_run
1583
1584Tells a Perl interpreter to run. See L<perlembed>.
1585
1586=cut
1587*/
1588
6224f72b 1589int
0cb96387 1590perl_run(pTHXx)
6224f72b 1591{
6224f72b 1592 I32 oldscope;
14dd3ad8 1593 int ret = 0;
db36c5a1 1594 dJMPENV;
4d1ff10f 1595#ifdef USE_5005THREADS
cea2e8a9
GS		 1596 dTHX;
1597#endif
6224f72b 1598
3280af22 1599 oldscope = PL_scopestack_ix;
96e176bf
CL		 1600#ifdef VMS
1601 VMSISH_HUSHED = 0;
1602#endif
6224f72b 1603
14dd3ad8 1604#ifdef PERL_FLEXIBLE_EXCEPTIONS
312caa8e 1605 redo_body:
14dd3ad8
GS		 1606 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vrun_body), oldscope);
1607#else
1608 JMPENV_PUSH(ret);
1609#endif
6224f72b
GS		 1610 switch (ret) {
1611 case 1:
1612 cxstack_ix = -1; /* start context stack again */
312caa8e 1613 goto redo_body;
14dd3ad8
GS		 1614 case 0: /* normal completion */
1615#ifndef PERL_FLEXIBLE_EXCEPTIONS
1616 redo_body:
1617 run_body(oldscope);
1618#endif
1619 /* FALL THROUGH */
1620 case 2: /* my_exit() */
3280af22 1621 while (PL_scopestack_ix > oldscope)
6224f72b
GS		 1622 LEAVE;
1623 FREETMPS;
3280af22 1624 PL_curstash = PL_defstash;
3a1ee7e8 1625 if (!(PL_exit_flags & PERL_EXIT_DESTRUCT_END) &&
31d77e54
AB		 1626 PL_endav && !PL_minus_c)
1627 call_list(oldscope, PL_endav);
6224f72b
GS		 1628#ifdef MYMALLOC
1629 if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
1630 dump_mstats("after execution: ");
1631#endif
14dd3ad8
GS		 1632 ret = STATUS_NATIVE_EXPORT;
1633 break;
6224f72b 1634 case 3:
312caa8e
CS		 1635 if (PL_restartop) {
1636 POPSTACK_TO(PL_mainstack);
1637 goto redo_body;
6224f72b 1638 }
bf49b057 1639 PerlIO_printf(Perl_error_log, "panic: restartop\n");
312caa8e 1640 FREETMPS;
14dd3ad8
GS		 1641 ret = 1;
1642 break;
6224f72b
GS		 1643 }
1644
14dd3ad8
GS		 1645 JMPENV_POP;
1646 return ret;
312caa8e
CS		 1647}
1648
14dd3ad8 1649#ifdef PERL_FLEXIBLE_EXCEPTIONS
312caa8e 1650STATIC void *
14dd3ad8 1651S_vrun_body(pTHX_ va_list args)
312caa8e 1652{
312caa8e
CS		 1653 I32 oldscope = va_arg(args, I32);
1654
14dd3ad8
GS		 1655 return run_body(oldscope);
1656}
1657#endif
1658
1659
1660STATIC void *
1661S_run_body(pTHX_ I32 oldscope)
1662{
6224f72b 1663 DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
3280af22 1664 PL_sawampersand ? "Enabling" : "Omitting"));
6224f72b 1665
3280af22 1666 if (!PL_restartop) {
6224f72b
GS		 1667 DEBUG_x(dump_all());
1668 DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
b900a521
JH		 1669 DEBUG_S(PerlIO_printf(Perl_debug_log, "main thread is 0x%"UVxf"\n",
1670 PTR2UV(thr)));
6224f72b 1671
3280af22 1672 if (PL_minus_c) {
bf4acbe4 1673#ifdef MACOS_TRADITIONAL
e69a2255
JH		 1674 PerlIO_printf(Perl_error_log, "%s%s syntax OK\n",
1675 (gMacPerl_ErrorFormat ? "# " : ""),
1676 MacPerl_MPWFileName(PL_origfilename));
bf4acbe4 1677#else
bf49b057 1678 PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename);
bf4acbe4 1679#endif
6224f72b
GS		 1680 my_exit(0);
1681 }
3280af22 1682 if (PERLDB_SINGLE && PL_DBsingle)
ac27b0f5 1683 sv_setiv(PL_DBsingle, 1);
3280af22
NIS		 1684 if (PL_initav)
1685 call_list(oldscope, PL_initav);
6224f72b
GS		 1686 }
1687
1688 /* do it */
1689
3280af22 1690 if (PL_restartop) {
533c011a 1691 PL_op = PL_restartop;
3280af22 1692 PL_restartop = 0;
cea2e8a9 1693 CALLRUNOPS(aTHX);
6224f72b 1694 }
3280af22
NIS		 1695 else if (PL_main_start) {
1696 CvDEPTH(PL_main_cv) = 1;
533c011a 1697 PL_op = PL_main_start;
cea2e8a9 1698 CALLRUNOPS(aTHX);
6224f72b
GS		 1699 }
1700
f6b3007c
JH		 1701 my_exit(0);
1702 /* NOTREACHED */
312caa8e 1703 return NULL;
6224f72b
GS		 1704}
1705
954c1994 1706/*
ccfc67b7
JH		 1707=head1 SV Manipulation Functions
1708
954c1994
GS		 1709=for apidoc p||get_sv
1710
1711Returns the SV of the specified Perl scalar. If C<create> is set and the
1712Perl variable does not exist then it will be created. If C<create> is not
1713set and the variable does not exist then NULL is returned.
1714
1715=cut
1716*/
1717
6224f72b 1718SV*
864dbfa3 1719Perl_get_sv(pTHX_ const char *name, I32 create)
6224f72b
GS		 1720{
1721 GV *gv;
4d1ff10f 1722#ifdef USE_5005THREADS
6224f72b
GS		 1723 if (name[1] == '\0' && !isALPHA(name[0])) {
1724 PADOFFSET tmp = find_threadsv(name);
411caa50 1725 if (tmp != NOT_IN_PAD)
6224f72b 1726 return THREADSV(tmp);
6224f72b 1727 }
4d1ff10f 1728#endif /* USE_5005THREADS */
6224f72b
GS		 1729 gv = gv_fetchpv(name, create, SVt_PV);
1730 if (gv)
1731 return GvSV(gv);
1732 return Nullsv;
1733}
1734
954c1994 1735/*
ccfc67b7
JH		 1736=head1 Array Manipulation Functions
1737
954c1994
GS		 1738=for apidoc p||get_av
1739
1740Returns the AV of the specified Perl array. If C<create> is set and the
1741Perl variable does not exist then it will be created. If C<create> is not
1742set and the variable does not exist then NULL is returned.
1743
1744=cut
1745*/
1746
6224f72b 1747AV*
864dbfa3 1748Perl_get_av(pTHX_ const char *name, I32 create)
6224f72b
GS		 1749{
1750 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
1751 if (create)
1752 return GvAVn(gv);
1753 if (gv)
1754 return GvAV(gv);
1755 return Nullav;
1756}
1757
954c1994 1758/*
ccfc67b7
JH		 1759=head1 Hash Manipulation Functions
1760
954c1994
GS		 1761=for apidoc p||get_hv
1762
1763Returns the HV of the specified Perl hash. If C<create> is set and the
1764Perl variable does not exist then it will be created. If C<create> is not
1765set and the variable does not exist then NULL is returned.
1766
1767=cut
1768*/
1769
6224f72b 1770HV*
864dbfa3 1771Perl_get_hv(pTHX_ const char *name, I32 create)
6224f72b 1772{
a0d0e21e
LW		 1773 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
1774 if (create)
1775 return GvHVn(gv);
1776 if (gv)
1777 return GvHV(gv);
1778 return Nullhv;
1779}
1780
954c1994 1781/*
ccfc67b7
JH		 1782=head1 CV Manipulation Functions
1783
954c1994
GS		 1784=for apidoc p||get_cv
1785
1786Returns the CV of the specified Perl subroutine. If C<create> is set and
1787the Perl subroutine does not exist then it will be declared (which has the
1788same effect as saying C<sub name;>). If C<create> is not set and the
1789subroutine does not exist then NULL is returned.
1790
1791=cut
1792*/
1793
a0d0e21e 1794CV*
864dbfa3 1795Perl_get_cv(pTHX_ const char *name, I32 create)
a0d0e21e
LW		 1796{
1797 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
b099ddc0 1798 /* XXX unsafe for threads if eval_owner isn't held */
f6ec51f7
GS		 1799 /* XXX this is probably not what they think they're getting.
1800 * It has the same effect as "sub name;", i.e. just a forward
1801 * declaration! */
8ebc5c01 1802 if (create && !GvCVu(gv))
774d564b 1803 return newSUB(start_subparse(FALSE, 0),
a0d0e21e 1804 newSVOP(OP_CONST, 0, newSVpv(name,0)),
4633a7c4 1805 Nullop,
a0d0e21e
LW		 1806 Nullop);
1807 if (gv)
8ebc5c01 1808 return GvCVu(gv);
a0d0e21e
LW		 1809 return Nullcv;
1810}
1811
79072805
LW		 1812/* Be sure to refetch the stack pointer after calling these routines. */
1813
954c1994 1814/*
ccfc67b7
JH		 1815
1816=head1 Callback Functions
1817
954c1994
GS		 1818=for apidoc p||call_argv
1819
1820Performs a callback to the specified Perl sub. See L<perlcall>.
1821
1822=cut
1823*/
1824
a0d0e21e 1825I32
864dbfa3 1826Perl_call_argv(pTHX_ const char *sub_name, I32 flags, register char **argv)
ac27b0f5 1827
8ac85365
NIS		 1828 /* See G_* flags in cop.h */
1829 /* null terminated arg list */
8990e307 1830{
a0d0e21e 1831 dSP;
8990e307 1832
924508f0 1833 PUSHMARK(SP);
a0d0e21e 1834 if (argv) {
8990e307 1835 while (*argv) {
a0d0e21e 1836 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
8990e307
LW		 1837 argv++;
1838 }
a0d0e21e 1839 PUTBACK;
8990e307 1840 }
864dbfa3 1841 return call_pv(sub_name, flags);
8990e307
LW		 1842}
1843
954c1994
GS		 1844/*
1845=for apidoc p||call_pv
1846
1847Performs a callback to the specified Perl sub. See L<perlcall>.
1848
1849=cut
1850*/
1851
a0d0e21e 1852I32
864dbfa3 1853Perl_call_pv(pTHX_ const char *sub_name, I32 flags)
8ac85365
NIS		 1854 /* name of the subroutine */
1855 /* See G_* flags in cop.h */
a0d0e21e 1856{
864dbfa3 1857 return call_sv((SV*)get_cv(sub_name, TRUE), flags);
a0d0e21e
LW		 1858}
1859
954c1994
GS		 1860/*
1861=for apidoc p||call_method
1862
1863Performs a callback to the specified Perl method. The blessed object must
1864be on the stack. See L<perlcall>.
1865
1866=cut
1867*/
1868
a0d0e21e 1869I32
864dbfa3 1870Perl_call_method(pTHX_ const char *methname, I32 flags)
8ac85365
NIS		 1871 /* name of the subroutine */
1872 /* See G_* flags in cop.h */
a0d0e21e 1873{
968b3946 1874 return call_sv(sv_2mortal(newSVpv(methname,0)), flags | G_METHOD);
a0d0e21e
LW		 1875}
1876
1877/* May be called with any of a CV, a GV, or an SV containing the name. */
954c1994
GS		 1878/*
1879=for apidoc p||call_sv
1880
1881Performs a callback to the Perl sub whose name is in the SV. See
1882L<perlcall>.
1883
1884=cut
1885*/
1886
a0d0e21e 1887I32
864dbfa3 1888Perl_call_sv(pTHX_ SV *sv, I32 flags)
8ac85365 1889 /* See G_* flags in cop.h */
a0d0e21e 1890{
924508f0 1891 dSP;
a0d0e21e 1892 LOGOP myop; /* fake syntax tree node */
968b3946 1893 UNOP method_op;
aa689395 1894 I32 oldmark;
13689cfe 1895 volatile I32 retval = 0;
a0d0e21e 1896 I32 oldscope;
54310121 1897 bool oldcatch = CATCH_GET;
6224f72b 1898 int ret;
533c011a 1899 OP* oldop = PL_op;
db36c5a1 1900 dJMPENV;
1e422769 1901
a0d0e21e
LW		 1902 if (flags & G_DISCARD) {
1903 ENTER;
1904 SAVETMPS;
1905 }
1906
aa689395 1907 Zero(&myop, 1, LOGOP);
54310121 1908 myop.op_next = Nullop;
f51d4af5 1909 if (!(flags & G_NOARGS))
aa689395 1910 myop.op_flags |= OPf_STACKED;
54310121 1911 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1912 (flags & G_ARRAY) ? OPf_WANT_LIST :
1913 OPf_WANT_SCALAR);
462e5cf6 1914 SAVEOP();
533c011a 1915 PL_op = (OP*)&myop;
aa689395 1916
3280af22
NIS		 1917 EXTEND(PL_stack_sp, 1);
1918 *++PL_stack_sp = sv;
aa689395 1919 oldmark = TOPMARK;
3280af22 1920 oldscope = PL_scopestack_ix;
a0d0e21e 1921
3280af22 1922 if (PERLDB_SUB && PL_curstash != PL_debstash
36477c24 1923 /* Handle first BEGIN of -d. */
3280af22 1924 && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub)))
36477c24 1925 /* Try harder, since this may have been a sighandler, thus
1926 * curstash may be meaningless. */
3280af22 1927 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != PL_debstash)
491527d0 1928 && !(flags & G_NODEBUG))
533c011a 1929 PL_op->op_private |= OPpENTERSUB_DB;
a0d0e21e 1930
968b3946
GS		 1931 if (flags & G_METHOD) {
1932 Zero(&method_op, 1, UNOP);
1933 method_op.op_next = PL_op;
1934 method_op.op_ppaddr = PL_ppaddr[OP_METHOD];
1935 myop.op_ppaddr = PL_ppaddr[OP_ENTERSUB];
f39d0b86 1936 PL_op = (OP*)&method_op;
968b3946
GS		 1937 }
1938
312caa8e 1939 if (!(flags & G_EVAL)) {
0cdb2077 1940 CATCH_SET(TRUE);
14dd3ad8 1941 call_body((OP*)&myop, FALSE);
312caa8e 1942 retval = PL_stack_sp - (PL_stack_base + oldmark);
0253cb41 1943 CATCH_SET(oldcatch);
312caa8e
CS		 1944 }
1945 else {
d78bda3d 1946 myop.op_other = (OP*)&myop;
3280af22 1947 PL_markstack_ptr--;
4633a7c4
LW		 1948 /* we're trying to emulate pp_entertry() here */
1949 {
c09156bb 1950 register PERL_CONTEXT *cx;
54310121 1951 I32 gimme = GIMME_V;
ac27b0f5 1952
4633a7c4
LW		 1953 ENTER;
1954 SAVETMPS;
ac27b0f5 1955
968b3946 1956 push_return(Nullop);
1d76a5c3 1957 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
4633a7c4 1958 PUSHEVAL(cx, 0, 0);
533c011a 1959 PL_eval_root = PL_op; /* Only needed so that goto works right. */
ac27b0f5 1960
faef0170 1961 PL_in_eval = EVAL_INEVAL;
4633a7c4 1962 if (flags & G_KEEPERR)
faef0170 1963 PL_in_eval |= EVAL_KEEPERR;
4633a7c4 1964 else
38a03e6e 1965 sv_setpv(ERRSV,"");
4633a7c4 1966 }
3280af22 1967 PL_markstack_ptr++;
a0d0e21e 1968
14dd3ad8
GS		 1969#ifdef PERL_FLEXIBLE_EXCEPTIONS
1970 redo_body:
1971 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_body),
db36c5a1 1972 (OP*)&myop, FALSE);
14dd3ad8
GS		 1973#else
1974 JMPENV_PUSH(ret);
1975#endif
6224f72b
GS		 1976 switch (ret) {
1977 case 0:
14dd3ad8
GS		 1978#ifndef PERL_FLEXIBLE_EXCEPTIONS
1979 redo_body:
1980 call_body((OP*)&myop, FALSE);
1981#endif
312caa8e
CS		 1982 retval = PL_stack_sp - (PL_stack_base + oldmark);
1983 if (!(flags & G_KEEPERR))
1984 sv_setpv(ERRSV,"");
a0d0e21e 1985 break;
6224f72b 1986 case 1:
f86702cc 1987 STATUS_ALL_FAILURE;
a0d0e21e 1988 /* FALL THROUGH */
6224f72b 1989 case 2:
a0d0e21e 1990 /* my_exit() was called */
3280af22 1991 PL_curstash = PL_defstash;
a0d0e21e 1992 FREETMPS;
14dd3ad8 1993 JMPENV_POP;
cc3604b1 1994 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
cea2e8a9 1995 Perl_croak(aTHX_ "Callback called exit");
f86702cc 1996 my_exit_jump();
a0d0e21e 1997 /* NOTREACHED */
6224f72b 1998 case 3:
3280af22 1999 if (PL_restartop) {
533c011a 2000 PL_op = PL_restartop;
3280af22 2001 PL_restartop = 0;
312caa8e 2002 goto redo_body;
a0d0e21e 2003 }
3280af22 2004 PL_stack_sp = PL_stack_base + oldmark;
a0d0e21e
LW		 2005 if (flags & G_ARRAY)
2006 retval = 0;
2007 else {
2008 retval = 1;
3280af22 2009 *++PL_stack_sp = &PL_sv_undef;
a0d0e21e 2010 }
312caa8e 2011 break;
a0d0e21e 2012 }
a0d0e21e 2013
3280af22 2014 if (PL_scopestack_ix > oldscope) {
a0a2876f
LW		 2015 SV **newsp;
2016 PMOP *newpm;
2017 I32 gimme;
c09156bb 2018 register PERL_CONTEXT *cx;
a0a2876f
LW		 2019 I32 optype;
2020
2021 POPBLOCK(cx,newpm);
2022 POPEVAL(cx);
2023 pop_return();
3280af22 2024 PL_curpm = newpm;
a0a2876f 2025 LEAVE;
a0d0e21e 2026 }
14dd3ad8 2027 JMPENV_POP;
a0d0e21e 2028 }
1e422769 2029
a0d0e21e 2030 if (flags & G_DISCARD) {
3280af22 2031 PL_stack_sp = PL_stack_base + oldmark;
a0d0e21e
LW		 2032 retval = 0;
2033 FREETMPS;
2034 LEAVE;
2035 }
533c011a 2036 PL_op = oldop;
a0d0e21e
LW		 2037 return retval;
2038}
2039
14dd3ad8 2040#ifdef PERL_FLEXIBLE_EXCEPTIONS
312caa8e 2041STATIC void *
14dd3ad8 2042S_vcall_body(pTHX_ va_list args)
312caa8e
CS		 2043{
2044 OP *myop = va_arg(args, OP*);
2045 int is_eval = va_arg(args, int);
2046
14dd3ad8 2047 call_body(myop, is_eval);
312caa8e
CS		 2048 return NULL;
2049}
14dd3ad8 2050#endif
312caa8e
CS		 2051
2052STATIC void
14dd3ad8 2053S_call_body(pTHX_ OP *myop, int is_eval)
312caa8e 2054{
312caa8e
CS		 2055 if (PL_op == myop) {
2056 if (is_eval)
f807eda9 2057 PL_op = Perl_pp_entereval(aTHX); /* this doesn't do a POPMARK */
312caa8e 2058 else
f807eda9 2059 PL_op = Perl_pp_entersub(aTHX); /* this does */
312caa8e
CS		 2060 }
2061 if (PL_op)
cea2e8a9 2062 CALLRUNOPS(aTHX);
312caa8e
CS		 2063}
2064
6e72f9df 2065/* Eval a string. The G_EVAL flag is always assumed. */
8990e307 2066
954c1994
GS		 2067/*
2068=for apidoc p||eval_sv
2069
2070Tells Perl to C<eval> the string in the SV.
2071
2072=cut
2073*/
2074
a0d0e21e 2075I32
864dbfa3 2076Perl_eval_sv(pTHX_ SV *sv, I32 flags)
ac27b0f5 2077
8ac85365 2078 /* See G_* flags in cop.h */
a0d0e21e 2079{
924508f0 2080 dSP;
a0d0e21e 2081 UNOP myop; /* fake syntax tree node */
8fa7f367 2082 volatile I32 oldmark = SP - PL_stack_base;
13689cfe 2083 volatile I32 retval = 0;
4633a7c4 2084 I32 oldscope;
6224f72b 2085 int ret;
533c011a 2086 OP* oldop = PL_op;
db36c5a1 2087 dJMPENV;
84902520 2088
4633a7c4
LW		 2089 if (flags & G_DISCARD) {
2090 ENTER;
2091 SAVETMPS;
2092 }
2093
462e5cf6 2094 SAVEOP();
533c011a
NIS		 2095 PL_op = (OP*)&myop;
2096 Zero(PL_op, 1, UNOP);
3280af22
NIS		 2097 EXTEND(PL_stack_sp, 1);
2098 *++PL_stack_sp = sv;
2099 oldscope = PL_scopestack_ix;
79072805 2100
4633a7c4
LW		 2101 if (!(flags & G_NOARGS))
2102 myop.op_flags = OPf_STACKED;
79072805 2103 myop.op_next = Nullop;
6e72f9df 2104 myop.op_type = OP_ENTEREVAL;
54310121 2105 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
2106 (flags & G_ARRAY) ? OPf_WANT_LIST :
2107 OPf_WANT_SCALAR);
6e72f9df 2108 if (flags & G_KEEPERR)
2109 myop.op_flags |= OPf_SPECIAL;
4633a7c4 2110
14dd3ad8 2111#ifdef PERL_FLEXIBLE_EXCEPTIONS
312caa8e 2112 redo_body:
14dd3ad8 2113 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_body),
db36c5a1 2114 (OP*)&myop, TRUE);
14dd3ad8
GS		 2115#else
2116 JMPENV_PUSH(ret);
2117#endif
6224f72b
GS		 2118 switch (ret) {
2119 case 0:
14dd3ad8
GS		 2120#ifndef PERL_FLEXIBLE_EXCEPTIONS
2121 redo_body:
2122 call_body((OP*)&myop,TRUE);
2123#endif
312caa8e
CS		 2124 retval = PL_stack_sp - (PL_stack_base + oldmark);
2125 if (!(flags & G_KEEPERR))
2126 sv_setpv(ERRSV,"");
4633a7c4 2127 break;
6224f72b 2128 case 1:
f86702cc 2129 STATUS_ALL_FAILURE;
4633a7c4 2130 /* FALL THROUGH */
6224f72b 2131 case 2:
4633a7c4 2132 /* my_exit() was called */
3280af22 2133 PL_curstash = PL_defstash;
4633a7c4 2134 FREETMPS;
14dd3ad8 2135 JMPENV_POP;
cc3604b1 2136 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
cea2e8a9 2137 Perl_croak(aTHX_ "Callback called exit");
f86702cc 2138 my_exit_jump();
4633a7c4 2139 /* NOTREACHED */
6224f72b 2140 case 3:
3280af22 2141 if (PL_restartop) {
533c011a 2142 PL_op = PL_restartop;
3280af22 2143 PL_restartop = 0;
312caa8e 2144 goto redo_body;
4633a7c4 2145 }
3280af22 2146 PL_stack_sp = PL_stack_base + oldmark;
4633a7c4
LW		 2147 if (flags & G_ARRAY)
2148 retval = 0;
2149 else {
2150 retval = 1;
3280af22 2151 *++PL_stack_sp = &PL_sv_undef;
4633a7c4 2152 }
312caa8e 2153 break;
4633a7c4
LW		 2154 }
2155
14dd3ad8 2156 JMPENV_POP;
4633a7c4 2157 if (flags & G_DISCARD) {
3280af22 2158 PL_stack_sp = PL_stack_base + oldmark;
4633a7c4
LW		 2159 retval = 0;
2160 FREETMPS;
2161 LEAVE;
2162 }
533c011a 2163 PL_op = oldop;
4633a7c4
LW		 2164 return retval;
2165}
2166
954c1994
GS		 2167/*
2168=for apidoc p||eval_pv
2169
2170Tells Perl to C<eval> the given string and return an SV* result.
2171
2172=cut
2173*/
2174
137443ea 2175SV*
864dbfa3 2176Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
137443ea 2177{
2178 dSP;
2179 SV* sv = newSVpv(p, 0);
2180
864dbfa3 2181 eval_sv(sv, G_SCALAR);
137443ea 2182 SvREFCNT_dec(sv);
2183
2184 SPAGAIN;
2185 sv = POPs;
2186 PUTBACK;
2187
2d8e6c8d
GS		 2188 if (croak_on_error && SvTRUE(ERRSV)) {
2189 STRLEN n_a;
cea2e8a9 2190 Perl_croak(aTHX_ SvPVx(ERRSV, n_a));
2d8e6c8d 2191 }
137443ea 2192
2193 return sv;
2194}
2195
4633a7c4
LW		 2196/* Require a module. */
2197
954c1994 2198/*
ccfc67b7
JH		 2199=head1 Embedding Functions
2200
954c1994
GS		 2201=for apidoc p||require_pv
2202
7d3fb230
BS		 2203Tells Perl to C<require> the file named by the string argument. It is
2204analogous to the Perl code C<eval "require '$file'">. It's even
2205implemented that way; consider using Perl_load_module instead.
954c1994 2206
7d3fb230 2207=cut */
954c1994 2208
4633a7c4 2209void
864dbfa3 2210Perl_require_pv(pTHX_ const char *pv)
4633a7c4 2211{
d3acc0f7
JP		 2212 SV* sv;
2213 dSP;
e788e7d3 2214 PUSHSTACKi(PERLSI_REQUIRE);
d3acc0f7
JP		 2215 PUTBACK;
2216 sv = sv_newmortal();
4633a7c4
LW		 2217 sv_setpv(sv, "require '");
2218 sv_catpv(sv, pv);
2219 sv_catpv(sv, "'");
864dbfa3 2220 eval_sv(sv, G_DISCARD);
d3acc0f7
JP		 2221 SPAGAIN;
2222 POPSTACK;
79072805
LW		 2223}
2224
79072805 2225void
864dbfa3 2226Perl_magicname(pTHX_ char *sym, char *name, I32 namlen)
79072805
LW		 2227{
2228 register GV *gv;
2229
155aba94 2230 if ((gv = gv_fetchpv(sym,TRUE, SVt_PV)))
14befaf4 2231 sv_magic(GvSV(gv), (SV*)gv, PERL_MAGIC_sv, name, namlen);
79072805
LW		 2232}
2233
76e3520e 2234STATIC void
cea2e8a9 2235S_usage(pTHX_ char *name) /* XXX move this out into a module ? */
4633a7c4 2236{
ab821d7f 2237 /* This message really ought to be max 23 lines.
75c72d73 2238 * Removed -h because the user already knows that option. Others? */
fb73857a 2239
76e3520e 2240 static char *usage_msg[] = {
fb73857a 2241"-0[octal] specify record separator (\\0, if no argument)",
2242"-a autosplit mode with -n or -p (splits $_ into @F)",
46487f74 2243"-C enable native wide character system interfaces",
1950ee41 2244"-c check syntax only (runs BEGIN and CHECK blocks)",
aac3bd0d
GS		 2245"-d[:debugger] run program under debugger",
2246"-D[number/list] set debugging flags (argument is a bit mask or alphabets)",
2247"-e 'command' one line of program (several -e's allowed, omit programfile)",
2248"-F/pattern/ split() pattern for -a switch (//'s are optional)",
2249"-i[extension] edit <> files in place (makes backup if extension supplied)",
2250"-Idirectory specify @INC/#include directory (several -I's allowed)",
fb73857a 2251"-l[octal] enable line ending processing, specifies line terminator",
aac3bd0d
GS		 2252"-[mM][-]module execute `use/no module...' before executing program",
2253"-n assume 'while (<>) { ... }' loop around program",
2254"-p assume loop like -n but print line also, like sed",
2255"-P run program through C preprocessor before compilation",
2256"-s enable rudimentary parsing for switches after programfile",
2257"-S look for programfile using PATH environment variable",
2258"-T enable tainting checks",
9cbc33e8 2259"-t enable tainting warnings",
aac3bd0d 2260"-u dump core after parsing program",
fb73857a 2261"-U allow unsafe operations",
aac3bd0d
GS		 2262"-v print version, subversion (includes VERY IMPORTANT perl info)",
2263"-V[:variable] print configuration summary (or a single Config.pm variable)",
2264"-w enable many useful warnings (RECOMMENDED)",
3c0facb2
GS		 2265"-W enable all warnings",
2266"-X disable all warnings",
fb73857a 2267"-x[directory] strip off text before #!perl line and perhaps cd to directory",
2268"\n",
2269NULL
2270};
76e3520e 2271 char **p = usage_msg;
fb73857a 2272
b0e47665
GS		 2273 PerlIO_printf(PerlIO_stdout(),
2274 "\nUsage: %s [switches] [--] [programfile] [arguments]",
2275 name);
fb73857a 2276 while (*p)
b0e47665 2277 PerlIO_printf(PerlIO_stdout(), "\n %s", *p++);
4633a7c4
LW		 2278}
2279
79072805
LW		 2280/* This routine handles any switches that can be given during run */
2281
2282char *
864dbfa3 2283Perl_moreswitches(pTHX_ char *s)
79072805 2284{
ba210ebe 2285 STRLEN numlen;
c07a80fd 2286 U32 rschar;
79072805
LW		 2287
2288 switch (*s) {
2289 case '0':
a863c7d1 2290 {
53305cf1
NC		 2291 I32 flags = 0;
2292 numlen = 4;
2293 rschar = (U32)grok_oct(s, &numlen, &flags, NULL);
8bfdd7d9 2294 SvREFCNT_dec(PL_rs);
c07a80fd 2295 if (rschar & ~((U8)~0))
8bfdd7d9 2296 PL_rs = &PL_sv_undef;
c07a80fd 2297 else if (!rschar && numlen >= 2)
8bfdd7d9 2298 PL_rs = newSVpvn("", 0);
c07a80fd 2299 else {
eb160463 2300 char ch = (char)rschar;
8bfdd7d9 2301 PL_rs = newSVpvn(&ch, 1);
79072805
LW		 2302 }
2303 return s + numlen;
a863c7d1 2304 }
46487f74
GS		 2305 case 'C':
2306 PL_widesyscalls = TRUE;
2307 s++;
2308 return s;
2304df62 2309 case 'F':
3280af22 2310 PL_minus_F = TRUE;
ebce5377
RGS		 2311 PL_splitstr = ++s;
2312 while (*s && !isSPACE(*s)) ++s;
2313 *s = '\0';
2314 PL_splitstr = savepv(PL_splitstr);
2304df62 2315 return s;
79072805 2316 case 'a':
3280af22 2317 PL_minus_a = TRUE;
79072805
LW		 2318 s++;
2319 return s;
2320 case 'c':
3280af22 2321 PL_minus_c = TRUE;
79072805
LW		 2322 s++;
2323 return s;
2324 case 'd':
bbce6d69 2325 forbid_setid("-d");
4633a7c4 2326 s++;
70c94a19
RR		 2327 /* The following permits -d:Mod to accepts arguments following an =
2328 in the fashion that -MSome::Mod does. */
2329 if (*s == ':' || *s == '=') {
2330 char *start;
2331 SV *sv;
2332 sv = newSVpv("use Devel::", 0);
2333 start = ++s;
2334 /* We now allow -d:Module=Foo,Bar */
2335 while(isALNUM(*s) || *s==':') ++s;
2336 if (*s != '=')
2337 sv_catpv(sv, start);
2338 else {
2339 sv_catpvn(sv, start, s-start);
2340 sv_catpv(sv, " split(/,/,q{");
2341 sv_catpv(sv, ++s);
2342 sv_catpv(sv, "})");
2343 }
4633a7c4 2344 s += strlen(s);
70c94a19 2345 my_setenv("PERL5DB", SvPV(sv, PL_na));
4633a7c4 2346 }
ed094faf 2347 if (!PL_perldb) {
3280af22 2348 PL_perldb = PERLDB_ALL;
a0d0e21e 2349 init_debugger();
ed094faf 2350 }
79072805
LW		 2351 return s;
2352 case 'D':
0453d815 2353 {
79072805 2354#ifdef DEBUGGING
bbce6d69 2355 forbid_setid("-D");
79072805 2356 if (isALPHA(s[1])) {
04932ac8 2357 /* if adding extra options, remember to update DEBUG_MASK */
1045810a 2358 static char debopts[] = "psltocPmfrxuLHXDSTRJ";
79072805
LW		 2359 char *d;
2360
93a17b20 2361 for (s++; *s && (d = strchr(debopts,*s)); s++)
3280af22 2362 PL_debug |= 1 << (d - debopts);
79072805
LW		 2363 }
2364 else {
3280af22 2365 PL_debug = atoi(s+1);
79072805
LW		 2366 for (s++; isDIGIT(*s); s++) ;
2367 }
2ac72d6e 2368#ifdef EBCDIC
12a43e32
JH		 2369 if (DEBUG_p_TEST_ && ckWARN_d(WARN_DEBUGGING))
2370 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
2371 "-Dp not implemented on this platform\n");
2372#endif
aea4f609 2373 PL_debug |= DEBUG_TOP_FLAG;
12a43e32 2374#else /* !DEBUGGING */
0453d815 2375 if (ckWARN_d(WARN_DEBUGGING))
9014280d 2376 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
0453d815 2377 "Recompile perl with -DDEBUGGING to use -D switch\n");
a0d0e21e 2378 for (s++; isALNUM(*s); s++) ;
79072805
LW		 2379#endif
2380 /*SUPPRESS 530*/
2381 return s;
0453d815 2382 }
4633a7c4 2383 case 'h':
ac27b0f5 2384 usage(PL_origargv[0]);
7ca617d0 2385 my_exit(0);
79072805 2386 case 'i':
3280af22
NIS		 2387 if (PL_inplace)
2388 Safefree(PL_inplace);
c030f24b
GH		 2389#if defined(__CYGWIN__) /* do backup extension automagically */
2390 if (*(s+1) == '\0') {
2391 PL_inplace = savepv(".bak");
2392 return s+1;
2393 }
2394#endif /* __CYGWIN__ */
3280af22 2395 PL_inplace = savepv(s+1);
79072805 2396 /*SUPPRESS 530*/
3280af22 2397 for (s = PL_inplace; *s && !isSPACE(*s); s++) ;
7b8d334a 2398 if (*s) {
fb73857a 2399 *s++ = '\0';
7b8d334a
GS		 2400 if (*s == '-') /* Additional switches on #! line. */
2401 s++;
2402 }
fb73857a 2403 return s;
4e49a025 2404 case 'I': /* -I handled both here and in parse_body() */
bbce6d69 2405 forbid_setid("-I");
fb73857a 2406 ++s;
2407 while (*s && isSPACE(*s))
2408 ++s;
2409 if (*s) {
774d564b 2410 char *e, *p;
0df16ed7
GS		 2411 p = s;
2412 /* ignore trailing spaces (possibly followed by other switches) */
2413 do {
2414 for (e = p; *e && !isSPACE(*e); e++) ;
2415 p = e;
2416 while (isSPACE(*p))
2417 p++;
2418 } while (*p && *p != '-');
2419 e = savepvn(s, e-s);
9c8a64f0 2420 incpush(e, TRUE, TRUE);
0df16ed7
GS		 2421 Safefree(e);
2422 s = p;
2423 if (*s == '-')
2424 s++;
79072805
LW		 2425 }
2426 else
a67e862a 2427 Perl_croak(aTHX_ "No directory specified for -I");
fb73857a 2428 return s;
79072805 2429 case 'l':
3280af22 2430 PL_minus_l = TRUE;
79072805 2431 s++;
7889fe52
NIS		 2432 if (PL_ors_sv) {
2433 SvREFCNT_dec(PL_ors_sv);
2434 PL_ors_sv = Nullsv;
2435 }
79072805 2436 if (isDIGIT(*s)) {
53305cf1 2437 I32 flags = 0;
7889fe52 2438 PL_ors_sv = newSVpvn("\n",1);
53305cf1
NC		 2439 numlen = 3 + (*s == '0');
2440 *SvPVX(PL_ors_sv) = (char)grok_oct(s, &numlen, &flags, NULL);
79072805
LW		 2441 s += numlen;
2442 }
2443 else {
8bfdd7d9 2444 if (RsPARA(PL_rs)) {
7889fe52
NIS		 2445 PL_ors_sv = newSVpvn("\n\n",2);
2446 }
2447 else {
8bfdd7d9 2448 PL_ors_sv = newSVsv(PL_rs);
c07a80fd 2449 }
79072805
LW		 2450 }
2451 return s;
1a30305b 2452 case 'M':
bbce6d69 2453 forbid_setid("-M"); /* XXX ? */
1a30305b 2454 /* FALL THROUGH */
2455 case 'm':
bbce6d69 2456 forbid_setid("-m"); /* XXX ? */
1a30305b 2457 if (*++s) {
a5f75d66 2458 char *start;
11343788 2459 SV *sv;
a5f75d66
AD		 2460 char *use = "use ";
2461 /* -M-foo == 'no foo' */
2462 if (*s == '-') { use = "no "; ++s; }
11343788 2463 sv = newSVpv(use,0);
a5f75d66 2464 start = s;
1a30305b 2465 /* We allow -M'Module qw(Foo Bar)' */
c07a80fd 2466 while(isALNUM(*s) || *s==':') ++s;
2467 if (*s != '=') {
11343788 2468 sv_catpv(sv, start);
c07a80fd 2469 if (*(start-1) == 'm') {
2470 if (*s != '\0')
cea2e8a9 2471 Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
11343788 2472 sv_catpv( sv, " ()");
c07a80fd 2473 }
2474 } else {
6df41af2 2475 if (s == start)
be98fb35
GS		 2476 Perl_croak(aTHX_ "Module name required with -%c option",
2477 s[-1]);
11343788
MB		 2478 sv_catpvn(sv, start, s-start);
2479 sv_catpv(sv, " split(/,/,q{");
2480 sv_catpv(sv, ++s);
2481 sv_catpv(sv, "})");
c07a80fd 2482 }
1a30305b 2483 s += strlen(s);
5c831c24 2484 if (!PL_preambleav)
3280af22
NIS		 2485 PL_preambleav = newAV();
2486 av_push(PL_preambleav, sv);
1a30305b 2487 }
2488 else
cea2e8a9 2489 Perl_croak(aTHX_ "No space allowed after -%c", *(s-1));
1a30305b 2490 return s;
79072805 2491 case 'n':
3280af22 2492 PL_minus_n = TRUE;
79072805
LW		 2493 s++;
2494 return s;
2495 case 'p':
3280af22 2496 PL_minus_p = TRUE;
79072805
LW		 2497 s++;
2498 return s;
2499 case 's':
bbce6d69 2500 forbid_setid("-s");
3280af22 2501 PL_doswitches = TRUE;
79072805
LW		 2502 s++;
2503 return s;
6537fe72
MS		 2504 case 't':
2505 if (!PL_tainting)
2506 Perl_croak(aTHX_ "Too late for \"-t\" option");
2507 s++;
2508 return s;
463ee0b2 2509 case 'T':
3280af22 2510 if (!PL_tainting)
cea2e8a9 2511 Perl_croak(aTHX_ "Too late for \"-T\" option");
463ee0b2
LW		 2512 s++;
2513 return s;
79072805 2514 case 'u':
bf4acbe4
GS		 2515#ifdef MACOS_TRADITIONAL
2516 Perl_croak(aTHX_ "Believe me, you don't want to use \"-u\" on a Macintosh");
2517#endif
3280af22 2518 PL_do_undump = TRUE;
79072805
LW		 2519 s++;
2520 return s;
2521 case 'U':
3280af22 2522 PL_unsafe = TRUE;
79072805
LW		 2523 s++;
2524 return s;
2525 case 'v':
8e9464f1 2526#if !defined(DGUX)
b0e47665 2527 PerlIO_printf(PerlIO_stdout(),
d2560b70 2528 Perl_form(aTHX_ "\nThis is perl, v%"VDf" built for %s",
b0e47665 2529 PL_patchlevel, ARCHNAME));
8e9464f1
JH		 2530#else /* DGUX */
2531/* Adjust verbose output as in the perl that ships with the DG/UX OS from EMC */
2532 PerlIO_printf(PerlIO_stdout(),
2533 Perl_form(aTHX_ "\nThis is perl, version %vd\n", PL_patchlevel));
2534 PerlIO_printf(PerlIO_stdout(),
2535 Perl_form(aTHX_ " built under %s at %s %s\n",
2536 OSNAME, __DATE__, __TIME__));
2537 PerlIO_printf(PerlIO_stdout(),
2538 Perl_form(aTHX_ " OS Specific Release: %s\n",
40a39f85 2539 OSVERS));
8e9464f1
JH		 2540#endif /* !DGUX */
2541
fb73857a 2542#if defined(LOCAL_PATCH_COUNT)
2543 if (LOCAL_PATCH_COUNT > 0)
b0e47665
GS		 2544 PerlIO_printf(PerlIO_stdout(),
2545 "\n(with %d registered patch%s, "
2546 "see perl -V for more detail)",
2547 (int)LOCAL_PATCH_COUNT,
2548 (LOCAL_PATCH_COUNT!=1) ? "es" : "");
a5f75d66 2549#endif
1a30305b 2550
b0e47665 2551 PerlIO_printf(PerlIO_stdout(),
be3c0a43 2552 "\n\nCopyright 1987-2002, Larry Wall\n");
eae9c151
JH		 2553#ifdef MACOS_TRADITIONAL
2554 PerlIO_printf(PerlIO_stdout(),
be3c0a43 2555 "\nMac OS port Copyright 1991-2002, Matthias Neeracher;\n"
03765510 2556 "maintained by Chris Nandor\n");
eae9c151 2557#endif
79072805 2558#ifdef MSDOS
b0e47665
GS		 2559 PerlIO_printf(PerlIO_stdout(),
2560 "\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
55497cff 2561#endif
2562#ifdef DJGPP
b0e47665
GS		 2563 PerlIO_printf(PerlIO_stdout(),
2564 "djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n"
2565 "djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
4633a7c4 2566#endif
79072805 2567#ifdef OS2
b0e47665
GS		 2568 PerlIO_printf(PerlIO_stdout(),
2569 "\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
be3c0a43 2570 "Version 5 port Copyright (c) 1994-2002, Andreas Kaiser, Ilya Zakharevich\n");
79072805 2571#endif
79072805 2572#ifdef atarist
b0e47665
GS		 2573 PerlIO_printf(PerlIO_stdout(),
2574 "atariST series port, ++jrb bammi@cadence.com\n");
79072805 2575#endif
a3f9223b 2576#ifdef __BEOS__
b0e47665
GS		 2577 PerlIO_printf(PerlIO_stdout(),
2578 "BeOS port Copyright Tom Spindler, 1997-1999\n");
a3f9223b 2579#endif
1d84e8df 2580#ifdef MPE
b0e47665 2581 PerlIO_printf(PerlIO_stdout(),
be3c0a43 2582 "MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-2002\n");
1d84e8df 2583#endif
9d116dd7 2584#ifdef OEMVS
b0e47665
GS		 2585 PerlIO_printf(PerlIO_stdout(),
2586 "MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
9d116dd7 2587#endif
495c5fdc 2588#ifdef __VOS__
b0e47665 2589 PerlIO_printf(PerlIO_stdout(),
94efb9fb 2590 "Stratus VOS port by Paul.Green@stratus.com, 1997-2002\n");
495c5fdc 2591#endif
092bebab 2592#ifdef __OPEN_VM
b0e47665
GS		 2593 PerlIO_printf(PerlIO_stdout(),
2594 "VM/ESA port by Neale Ferguson, 1998-1999\n");
092bebab 2595#endif
a1a0e61e 2596#ifdef POSIX_BC
b0e47665
GS		 2597 PerlIO_printf(PerlIO_stdout(),
2598 "BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
a1a0e61e 2599#endif
61ae2fbf 2600#ifdef __MINT__
b0e47665
GS		 2601 PerlIO_printf(PerlIO_stdout(),
2602 "MiNT port by Guido Flohr, 1997-1999\n");
61ae2fbf 2603#endif
f83d2536 2604#ifdef EPOC
b0e47665 2605 PerlIO_printf(PerlIO_stdout(),
be3c0a43 2606 "EPOC port by Olaf Flebbe, 1999-2002\n");
f83d2536 2607#endif
e1caacb4 2608#ifdef UNDER_CE
be3c0a43 2609 printf("WINCE port by Rainer Keuchel, 2001-2002\n");
e1caacb4
JH		 2610 printf("Built on " __DATE__ " " __TIME__ "\n\n");
2611 wce_hitreturn();
2612#endif
baed7233
DL		 2613#ifdef BINARY_BUILD_NOTICE
2614 BINARY_BUILD_NOTICE;
2615#endif
b0e47665
GS		 2616 PerlIO_printf(PerlIO_stdout(),
2617 "\n\
79072805 2618Perl may be copied only under the terms of either the Artistic License or the\n\
3d6f292d 2619GNU General Public License, which may be found in the Perl 5 source kit.\n\n\
95103687
GS		 2620Complete documentation for Perl, including FAQ lists, should be found on\n\
2621this system using `man perl' or `perldoc perl'. If you have access to the\n\
2622Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n");
7ca617d0 2623 my_exit(0);
79072805 2624 case 'w':
599cee73 2625 if (! (PL_dowarn & G_WARN_ALL_MASK))
ac27b0f5 2626 PL_dowarn |= G_WARN_ON;
599cee73
PM		 2627 s++;
2628 return s;
2629 case 'W':
ac27b0f5 2630 PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
317ea90d
MS		 2631 if (!specialWARN(PL_compiling.cop_warnings))
2632 SvREFCNT_dec(PL_compiling.cop_warnings);
d3a7d8c7 2633 PL_compiling.cop_warnings = pWARN_ALL ;
599cee73
PM		 2634 s++;
2635 return s;
2636 case 'X':
ac27b0f5 2637 PL_dowarn = G_WARN_ALL_OFF;
317ea90d
MS		 2638 if (!specialWARN(PL_compiling.cop_warnings))
2639 SvREFCNT_dec(PL_compiling.cop_warnings);
d3a7d8c7 2640 PL_compiling.cop_warnings = pWARN_NONE ;
79072805
LW		 2641 s++;
2642 return s;
a0d0e21e 2643 case '*':
79072805
LW		 2644 case ' ':
2645 if (s[1] == '-') /* Additional switches on #! line. */
2646 return s+2;
2647 break;
a0d0e21e 2648 case '-':
79072805 2649 case 0:
51882d45 2650#if defined(WIN32) || !defined(PERL_STRICT_CR)
a868473f
NIS		 2651 case '\r':
2652#endif
79072805
LW		 2653 case '\n':
2654 case '\t':
2655 break;
aa689395 2656#ifdef ALTERNATE_SHEBANG
2657 case 'S': /* OS/2 needs -S on "extproc" line. */
2658 break;
2659#endif
a0d0e21e 2660 case 'P':
3280af22 2661 if (PL_preprocess)
a0d0e21e
LW		 2662 return s+1;
2663 /* FALL THROUGH */
79072805 2664 default:
cea2e8a9 2665 Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
79072805
LW		 2666 }
2667 return Nullch;
2668}
2669
2670/* compliments of Tom Christiansen */
2671
2672/* unexec() can be found in the Gnu emacs distribution */
ee580363 2673/* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
79072805
LW		 2674
2675void
864dbfa3 2676Perl_my_unexec(pTHX)
79072805
LW		 2677{
2678#ifdef UNEXEC
46fc3d4c 2679 SV* prog;
2680 SV* file;
ee580363 2681 int status = 1;
79072805
LW		 2682 extern int etext;
2683
ee580363 2684 prog = newSVpv(BIN_EXP, 0);
46fc3d4c 2685 sv_catpv(prog, "/perl");
6b88bc9c 2686 file = newSVpv(PL_origfilename, 0);
46fc3d4c 2687 sv_catpv(file, ".perldump");
79072805 2688
ee580363
GS		 2689 unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
2690 /* unexec prints msg to stderr in case of failure */
6ad3d225 2691 PerlProc_exit(status);
79072805 2692#else
a5f75d66
AD		 2693# ifdef VMS
2694# include <lib$routines.h>
2695 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
aa689395 2696# else
79072805 2697 ABORT(); /* for use with undump */
aa689395 2698# endif
a5f75d66 2699#endif
79072805
LW		 2700}
2701
cb68f92d
GS		 2702/* initialize curinterp */
2703STATIC void
cea2e8a9 2704S_init_interp(pTHX)
cb68f92d
GS		 2705{
2706
acfe0abc
GS		 2707#ifdef MULTIPLICITY
2708# define PERLVAR(var,type)
2709# define PERLVARA(var,n,type)
2710# if defined(PERL_IMPLICIT_CONTEXT)
2711# if defined(USE_5005THREADS)
2712# define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
c5be433b 2713# define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
acfe0abc
GS		 2714# else /* !USE_5005THREADS */
2715# define PERLVARI(var,type,init) aTHX->var = init;
2716# define PERLVARIC(var,type,init) aTHX->var = init;
2717# endif /* USE_5005THREADS */
3967c732 2718# else
acfe0abc
GS		 2719# define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
2720# define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
066ef5b5 2721# endif
acfe0abc
GS		 2722# include "intrpvar.h"
2723# ifndef USE_5005THREADS
2724# include "thrdvar.h"
2725# endif
2726# undef PERLVAR
2727# undef PERLVARA
2728# undef PERLVARI
2729# undef PERLVARIC
2730#else
2731# define PERLVAR(var,type)
2732# define PERLVARA(var,n,type)
2733# define PERLVARI(var,type,init) PL_##var = init;
2734# define PERLVARIC(var,type,init) PL_##var = init;
2735# include "intrpvar.h"
2736# ifndef USE_5005THREADS
2737# include "thrdvar.h"
2738# endif
2739# undef PERLVAR
2740# undef PERLVARA
2741# undef PERLVARI
2742# undef PERLVARIC
cb68f92d
GS		 2743#endif
2744
cb68f92d
GS		 2745}
2746
76e3520e 2747STATIC void
cea2e8a9 2748S_init_main_stash(pTHX)
79072805 2749{
463ee0b2 2750 GV *gv;
6e72f9df 2751
3280af22 2752 PL_curstash = PL_defstash = newHV();
79cb57f6 2753 PL_curstname = newSVpvn("main",4);
adbc6bb1
LW		 2754 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
2755 SvREFCNT_dec(GvHV(gv));
3280af22 2756 GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);
463ee0b2 2757 SvREADONLY_on(gv);
3280af22
NIS		 2758 HvNAME(PL_defstash) = savepv("main");
2759 PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
2760 GvMULTI_on(PL_incgv);
2761 PL_hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */
2762 GvMULTI_on(PL_hintgv);
2763 PL_defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
2764 PL_errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
2765 GvMULTI_on(PL_errgv);
2766 PL_replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */
2767 GvMULTI_on(PL_replgv);
cea2e8a9 2768 (void)Perl_form(aTHX_ "%240s",""); /* Preallocate temp - for immediate signals. */
38a03e6e
MB		 2769 sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
2770 sv_setpvn(ERRSV, "", 0);
3280af22 2771 PL_curstash = PL_defstash;
11faa288 2772 CopSTASH_set(&PL_compiling, PL_defstash);
ed094faf 2773 PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
3280af22 2774 PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
92d29cee 2775 PL_nullstash = GvHV(gv_fetchpv("<none>::", GV_ADDMULTI, SVt_PVHV));
4633a7c4 2776 /* We must init $/ before switches are processed. */
864dbfa3 2777 sv_setpvn(get_sv("/", TRUE), "\n", 1);
79072805
LW		 2778}
2779
76e3520e 2780STATIC void
cea2e8a9 2781S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript)
79072805 2782{
1b24ed4b
MS		 2783 char *quote;
2784 char *code;
2785 char *cpp_discard_flag;
2786 char *perl;
2787
6c4ab083 2788 *fdscript = -1;
79072805 2789
3280af22
NIS		 2790 if (PL_e_script) {
2791 PL_origfilename = savepv("-e");
96436eeb 2792 }
6c4ab083
GS		 2793 else {
2794 /* if find_script() returns, it returns a malloc()-ed value */
3280af22 2795 PL_origfilename = scriptname = find_script(scriptname, dosearch, NULL, 1);
6c4ab083
GS		 2796
2797 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
2798 char *s = scriptname + 8;
2799 *fdscript = atoi(s);
2800 while (isDIGIT(*s))
2801 s++;
2802 if (*s) {
2803 scriptname = savepv(s + 1);
3280af22
NIS		 2804 Safefree(PL_origfilename);
2805 PL_origfilename = scriptname;
6c4ab083
GS		 2806 }
2807 }
2808 }
2809
05ec9bb3 2810 CopFILE_free(PL_curcop);
57843af0 2811 CopFILE_set(PL_curcop, PL_origfilename);
3280af22 2812 if (strEQ(PL_origfilename,"-"))
79072805 2813 scriptname = "";
01f988be 2814 if (*fdscript >= 0) {
3280af22 2815 PL_rsfp = PerlIO_fdopen(*fdscript,PERL_SCRIPT_MODE);
1b24ed4b
MS		 2816# if defined(HAS_FCNTL) && defined(F_SETFD)
2817 if (PL_rsfp)
2818 /* ensure close-on-exec */
2819 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);
2820# endif
96436eeb 2821 }
3280af22 2822 else if (PL_preprocess) {
46fc3d4c 2823 char *cpp_cfg = CPPSTDIN;
79cb57f6 2824 SV *cpp = newSVpvn("",0);
46fc3d4c 2825 SV *cmd = NEWSV(0,0);
2826
2827 if (strEQ(cpp_cfg, "cppstdin"))
cea2e8a9 2828 Perl_sv_catpvf(aTHX_ cpp, "%s/", BIN_EXP);
46fc3d4c 2829 sv_catpv(cpp, cpp_cfg);
79072805 2830
1b24ed4b
MS		 2831# ifndef VMS
2832 sv_catpvn(sv, "-I", 2);
2833 sv_catpv(sv,PRIVLIB_EXP);
2834# endif
46fc3d4c 2835
14953ddc
MB		 2836 DEBUG_P(PerlIO_printf(Perl_debug_log,
2837 "PL_preprocess: scriptname=\"%s\", cpp=\"%s\", sv=\"%s\", CPPMINUS=\"%s\"\n",
2838 scriptname, SvPVX (cpp), SvPVX (sv), CPPMINUS));
1b24ed4b
MS		 2839
2840# if defined(MSDOS) || defined(WIN32) || defined(VMS)
2841 quote = "\"";
2842# else
2843 quote = "'";
2844# endif
2845
2846# ifdef VMS
2847 cpp_discard_flag = "";
2848# else
2849 cpp_discard_flag = "-C";
2850# endif
2851
2852# ifdef OS2
2853 perl = os2_execname(aTHX);
2854# else
2855 perl = PL_origargv[0];
2856# endif
2857
2858
2859 /* This strips off Perl comments which might interfere with
62375a60
NIS		 2860 the C pre-processor, including #!. #line directives are
2861 deliberately stripped to avoid confusion with Perl's version
1b24ed4b
MS		 2862 of #line. FWP played some golf with it so it will fit
2863 into VMS's 255 character buffer.
2864 */
2865 if( PL_doextract )
2866 code = "(1../^#!.*perl/i)|/^\\s*#(?!\\s*((ifn?|un)def|(el|end)?if|define|include|else|error|pragma)\\b)/||!($|=1)||print";
2867 else
2868 code = "/^\\s*#(?!\\s*((ifn?|un)def|(el|end)?if|define|include|else|error|pragma)\\b)/||!($|=1)||print";
2869
2870 Perl_sv_setpvf(aTHX_ cmd, "\
2871%s -ne%s%s%s %s | %"SVf" %s %"SVf" %s",
62375a60 2872 perl, quote, code, quote, scriptname, cpp,
1b24ed4b
MS		 2873 cpp_discard_flag, sv, CPPMINUS);
2874
3280af22 2875 PL_doextract = FALSE;
1b24ed4b
MS		 2876# ifdef IAMSUID /* actually, this is caught earlier */
2877 if (PL_euid != PL_uid && !PL_euid) { /* if running suidperl */
2878# ifdef HAS_SETEUID
2879 (void)seteuid(PL_uid); /* musn't stay setuid root */
2880# else
2881# ifdef HAS_SETREUID
2882 (void)setreuid((Uid_t)-1, PL_uid);
2883# else
2884# ifdef HAS_SETRESUID
2885 (void)setresuid((Uid_t)-1, PL_uid, (Uid_t)-1);
2886# else
2887 PerlProc_setuid(PL_uid);
2888# endif
2889# endif
2890# endif
b28d0864 2891 if (PerlProc_geteuid() != PL_uid)
cea2e8a9 2892 Perl_croak(aTHX_ "Can't do seteuid!\n");
79072805 2893 }
1b24ed4b 2894# endif /* IAMSUID */
0a6c758d 2895
62375a60
NIS		 2896 DEBUG_P(PerlIO_printf(Perl_debug_log,
2897 "PL_preprocess: cmd=\"%s\"\n",
0a6c758d
MS		 2898 SvPVX(cmd)));
2899
3280af22 2900 PL_rsfp = PerlProc_popen(SvPVX(cmd), "r");
46fc3d4c 2901 SvREFCNT_dec(cmd);
2902 SvREFCNT_dec(cpp);
79072805
LW		 2903 }
2904 else if (!*scriptname) {
bbce6d69 2905 forbid_setid("program input from stdin");
3280af22 2906 PL_rsfp = PerlIO_stdin();
79072805 2907 }
96436eeb 2908 else {
3280af22 2909 PL_rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
1b24ed4b
MS		 2910# if defined(HAS_FCNTL) && defined(F_SETFD)
2911 if (PL_rsfp)
2912 /* ensure close-on-exec */
2913 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);
2914# endif
96436eeb 2915 }
3280af22 2916 if (!PL_rsfp) {
1b24ed4b
MS		 2917# ifdef DOSUID
2918# ifndef IAMSUID /* in case script is not readable before setuid */
2919 if (PL_euid &&
2920 PerlLIO_stat(CopFILE(PL_curcop),&PL_statbuf) >= 0 &&
2921 PL_statbuf.st_mode & (S_ISUID|S_ISGID))
2922 {
2923 /* try again */
62375a60
NIS		 2924 PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT,
2925 BIN_EXP, (int)PERL_REVISION,
1b24ed4b
MS		 2926 (int)PERL_VERSION,
2927 (int)PERL_SUBVERSION), PL_origargv);
2928 Perl_croak(aTHX_ "Can't do setuid\n");
2929 }
2930# endif
2931# endif
2932# ifdef IAMSUID
2933 errno = EPERM;
2934 Perl_croak(aTHX_ "Can't open perl script: %s\n",
2935 Strerror(errno));
2936# else
2937 Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
2938 CopFILE(PL_curcop), Strerror(errno));
2939# endif
13281fa4 2940 }
79072805 2941}
8d063cd8 2942
7b89560d
JH		 2943/* Mention
2944 * I_SYSSTATVFS HAS_FSTATVFS
2945 * I_SYSMOUNT
c890dc6c 2946 * I_STATFS HAS_FSTATFS HAS_GETFSSTAT
7b89560d
JH		 2947 * I_MNTENT HAS_GETMNTENT HAS_HASMNTOPT
2948 * here so that metaconfig picks them up. */
2949
104d25b7 2950#ifdef IAMSUID
864dbfa3 2951STATIC int
e688b231 2952S_fd_on_nosuid_fs(pTHX_ int fd)
104d25b7 2953{
0545a864
JH		 2954 int check_okay = 0; /* able to do all the required sys/libcalls */
2955 int on_nosuid = 0; /* the fd is on a nosuid fs */
104d25b7 2956/*
ad27e871 2957 * Preferred order: fstatvfs(), fstatfs(), ustat()+getmnt(), getmntent().
e688b231 2958 * fstatvfs() is UNIX98.
0545a864 2959 * fstatfs() is 4.3 BSD.
ad27e871 2960 * ustat()+getmnt() is pre-4.3 BSD.
0545a864
JH		 2961 * getmntent() is O(number-of-mounted-filesystems) and can hang on
2962 * an irrelevant filesystem while trying to reach the right one.
104d25b7
JH		 2963 */
2964
6439433f
JH		 2965#undef FD_ON_NOSUID_CHECK_OKAY /* found the syscalls to do the check? */
2966
2967# if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
2968 defined(HAS_FSTATVFS)
2969# define FD_ON_NOSUID_CHECK_OKAY
104d25b7 2970 struct statvfs stfs;
6439433f 2971
104d25b7
JH		 2972 check_okay = fstatvfs(fd, &stfs) == 0;
2973 on_nosuid = check_okay && (stfs.f_flag & ST_NOSUID);
6439433f 2974# endif /* fstatvfs */
ac27b0f5 2975
6439433f
JH		 2976# if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
2977 defined(PERL_MOUNT_NOSUID) && \
2978 defined(HAS_FSTATFS) && \
2979 defined(HAS_STRUCT_STATFS) && \
2980 defined(HAS_STRUCT_STATFS_F_FLAGS)
2981# define FD_ON_NOSUID_CHECK_OKAY
e688b231 2982 struct statfs stfs;
6439433f 2983
104d25b7 2984 check_okay = fstatfs(fd, &stfs) == 0;
104d25b7 2985 on_nosuid = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID);
6439433f
JH		 2986# endif /* fstatfs */
2987
2988# if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
2989 defined(PERL_MOUNT_NOSUID) && \
2990 defined(HAS_FSTAT) && \
2991 defined(HAS_USTAT) && \
2992 defined(HAS_GETMNT) && \
2993 defined(HAS_STRUCT_FS_DATA) && \
2994 defined(NOSTAT_ONE)
2995# define FD_ON_NOSUID_CHECK_OKAY
c623ac67 2996 Stat_t fdst;
6439433f 2997
0545a864 2998 if (fstat(fd, &fdst) == 0) {
6439433f
JH		 2999 struct ustat us;
3000 if (ustat(fdst.st_dev, &us) == 0) {
3001 struct fs_data fsd;
3002 /* NOSTAT_ONE here because we're not examining fields which
3003 * vary between that case and STAT_ONE. */
ad27e871 3004 if (getmnt((int*)0, &fsd, (int)0, NOSTAT_ONE, us.f_fname) == 0) {
6439433f
JH		 3005 size_t cmplen = sizeof(us.f_fname);
3006 if (sizeof(fsd.fd_req.path) < cmplen)
3007 cmplen = sizeof(fsd.fd_req.path);
3008 if (strnEQ(fsd.fd_req.path, us.f_fname, cmplen) &&
3009 fdst.st_dev == fsd.fd_req.dev) {
3010 check_okay = 1;
3011 on_nosuid = fsd.fd_req.flags & PERL_MOUNT_NOSUID;
3012 }
3013 }
3014 }
3015 }
0545a864 3016 }
6439433f
JH		 3017# endif /* fstat+ustat+getmnt */
3018
3019# if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
3020 defined(HAS_GETMNTENT) && \
3021 defined(HAS_HASMNTOPT) && \
3022 defined(MNTOPT_NOSUID)
3023# define FD_ON_NOSUID_CHECK_OKAY
3024 FILE *mtab = fopen("/etc/mtab", "r");
3025 struct mntent *entry;
c623ac67 3026 Stat_t stb, fsb;
104d25b7
JH		 3027
3028 if (mtab && (fstat(fd, &stb) == 0)) {
6439433f
JH		 3029 while (entry = getmntent(mtab)) {
3030 if (stat(entry->mnt_dir, &fsb) == 0
3031 && fsb.st_dev == stb.st_dev)
3032 {
3033 /* found the filesystem */
3034 check_okay = 1;
3035 if (hasmntopt(entry, MNTOPT_NOSUID))
3036 on_nosuid = 1;
3037 break;
3038 } /* A single fs may well fail its stat(). */
3039 }
104d25b7
JH		 3040 }
3041 if (mtab)
6439433f
JH		 3042 fclose(mtab);
3043# endif /* getmntent+hasmntopt */
0545a864 3044
ac27b0f5 3045 if (!check_okay)
0545a864 3046 Perl_croak(aTHX_ "Can't check filesystem of script \"%s\" for nosuid", PL_origfilename);
104d25b7
JH		 3047 return on_nosuid;
3048}
3049#endif /* IAMSUID */
3050
76e3520e 3051STATIC void
cea2e8a9 3052S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript)
79072805 3053{
155aba94 3054#ifdef IAMSUID
96436eeb 3055 int which;
155aba94 3056#endif
96436eeb 3057
13281fa4
LW		 3058 /* do we need to emulate setuid on scripts? */
3059
3060 /* This code is for those BSD systems that have setuid #! scripts disabled
3061 * in the kernel because of a security problem. Merely defining DOSUID
3062 * in perl will not fix that problem, but if you have disabled setuid
3063 * scripts in the kernel, this will attempt to emulate setuid and setgid
3064 * on scripts that have those now-otherwise-useless bits set. The setuid
27e2fb84
LW		 3065 * root version must be called suidperl or sperlN.NNN. If regular perl
3066 * discovers that it has opened a setuid script, it calls suidperl with
3067 * the same argv that it had. If suidperl finds that the script it has
3068 * just opened is NOT setuid root, it sets the effective uid back to the
3069 * uid. We don't just make perl setuid root because that loses the
3070 * effective uid we had before invoking perl, if it was different from the
3071 * uid.
13281fa4
LW		 3072 *
3073 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
3074 * be defined in suidperl only. suidperl must be setuid root. The
3075 * Configure script will set this up for you if you want it.
3076 */
a687059c 3077
13281fa4 3078#ifdef DOSUID
6e72f9df 3079 char *s, *s2;
a0d0e21e 3080
b28d0864 3081 if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0) /* normal stat is insecure */
cea2e8a9 3082 Perl_croak(aTHX_ "Can't stat script \"%s\"",PL_origfilename);
b28d0864 3083 if (fdscript < 0 && PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
79072805 3084 I32 len;
2d8e6c8d 3085 STRLEN n_a;
13281fa4 3086
a687059c 3087#ifdef IAMSUID
fe14fcc3 3088#ifndef HAS_SETREUID
a687059c
LW		 3089 /* On this access check to make sure the directories are readable,
3090 * there is actually a small window that the user could use to make
3091 * filename point to an accessible directory. So there is a faint
3092 * chance that someone could execute a setuid script down in a
3093 * non-accessible directory. I don't know what to do about that.
3094 * But I don't think it's too important. The manual lies when
3095 * it says access() is useful in setuid programs.
3096 */
cc49e20b 3097 if (PerlLIO_access(CopFILE(PL_curcop),1)) /*double check*/
cea2e8a9 3098 Perl_croak(aTHX_ "Permission denied");
a687059c
LW		 3099#else
3100 /* If we can swap euid and uid, then we can determine access rights
3101 * with a simple stat of the file, and then compare device and
3102 * inode to make sure we did stat() on the same file we opened.
3103 * Then we just have to make sure he or she can execute it.
3104 */
3105 {
c623ac67 3106 Stat_t tmpstatbuf;
a687059c 3107
85e6fe83
LW		 3108 if (
3109#ifdef HAS_SETREUID
b28d0864 3110 setreuid(PL_euid,PL_uid) < 0
a0d0e21e
LW		 3111#else
3112# if HAS_SETRESUID
b28d0864 3113 setresuid(PL_euid,PL_uid,(Uid_t)-1) < 0
a0d0e21e 3114# endif
85e6fe83 3115#endif
b28d0864 3116 || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
cea2e8a9 3117 Perl_croak(aTHX_ "Can't swap uid and euid"); /* really paranoid */
cc49e20b 3118 if (PerlLIO_stat(CopFILE(PL_curcop),&tmpstatbuf) < 0)
cea2e8a9 3119 Perl_croak(aTHX_ "Permission denied"); /* testing full pathname here */
2bb3463c 3120#if defined(IAMSUID) && !defined(NO_NOSUID_CHECK)
e688b231 3121 if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp)))
cea2e8a9 3122 Perl_croak(aTHX_ "Permission denied");
104d25b7 3123#endif
b28d0864
NIS		 3124 if (tmpstatbuf.st_dev != PL_statbuf.st_dev ||
3125 tmpstatbuf.st_ino != PL_statbuf.st_ino) {
3126 (void)PerlIO_close(PL_rsfp);
cea2e8a9 3127 Perl_croak(aTHX_ "Permission denied\n");
a687059c 3128 }
85e6fe83
LW		 3129 if (
3130#ifdef HAS_SETREUID
b28d0864 3131 setreuid(PL_uid,PL_euid) < 0
a0d0e21e
LW		 3132#else
3133# if defined(HAS_SETRESUID)
b28d0864 3134 setresuid(PL_uid,PL_euid,(Uid_t)-1) < 0
a0d0e21e 3135# endif
85e6fe83 3136#endif
b28d0864 3137 || PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid)
cea2e8a9 3138 Perl_croak(aTHX_ "Can't reswap uid and euid");
b28d0864 3139 if (!cando(S_IXUSR,FALSE,&PL_statbuf)) /* can real uid exec? */
cea2e8a9 3140 Perl_croak(aTHX_ "Permission denied\n");
a687059c 3141 }
fe14fcc3 3142#endif /* HAS_SETREUID */
a687059c
LW		 3143#endif /* IAMSUID */
3144
b28d0864 3145 if (!S_ISREG(PL_statbuf.st_mode))
cea2e8a9 3146 Perl_croak(aTHX_ "Permission denied");
b28d0864 3147 if (PL_statbuf.st_mode & S_IWOTH)
cea2e8a9 3148 Perl_croak(aTHX_ "Setuid/gid script is writable by world");
6b88bc9c 3149 PL_doswitches = FALSE; /* -s is insecure in suid */
57843af0 3150 CopLINE_inc(PL_curcop);
6b88bc9c 3151 if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch ||
2d8e6c8d 3152 strnNE(SvPV(PL_linestr,n_a),"#!",2) ) /* required even on Sys V */
cea2e8a9 3153 Perl_croak(aTHX_ "No #! line");
2d8e6c8d 3154 s = SvPV(PL_linestr,n_a)+2;
663a0e37 3155 if (*s == ' ') s++;
45d8adaa 3156 while (!isSPACE(*s)) s++;
2d8e6c8d 3157 for (s2 = s; (s2 > SvPV(PL_linestr,n_a)+2 &&
6e72f9df 3158 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
3159 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
cea2e8a9 3160 Perl_croak(aTHX_ "Not a perl script");
a687059c 3161 while (*s == ' ' || *s == '\t') s++;
13281fa4
LW		 3162 /*
3163 * #! arg must be what we saw above. They can invoke it by
3164 * mentioning suidperl explicitly, but they may not add any strange
3165 * arguments beyond what #! says if they do invoke suidperl that way.
3166 */
3167 len = strlen(validarg);
3168 if (strEQ(validarg," PHOOEY ") ||
45d8adaa 3169 strnNE(s,validarg,len) || !isSPACE(s[len]))
cea2e8a9 3170 Perl_croak(aTHX_ "Args must match #! line");
a687059c
LW		 3171
3172#ifndef IAMSUID
b28d0864
NIS		 3173 if (PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
3174 PL_euid == PL_statbuf.st_uid)
3175 if (!PL_do_undump)
cea2e8a9 3176 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
a687059c
LW		 3177FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
3178#endif /* IAMSUID */
13281fa4 3179
b28d0864
NIS		 3180 if (PL_euid) { /* oops, we're not the setuid root perl */
3181 (void)PerlIO_close(PL_rsfp);
13281fa4 3182#ifndef IAMSUID
46fc3d4c 3183 /* try again */
a7cb1f99 3184 PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, BIN_EXP,
273cf8d1
GS		 3185 (int)PERL_REVISION, (int)PERL_VERSION,
3186 (int)PERL_SUBVERSION), PL_origargv);
13281fa4 3187#endif
cea2e8a9 3188 Perl_croak(aTHX_ "Can't do setuid\n");
13281fa4
LW		 3189 }
3190
b28d0864 3191 if (PL_statbuf.st_mode & S_ISGID && PL_statbuf.st_gid != PL_egid) {
fe14fcc3 3192#ifdef HAS_SETEGID
b28d0864 3193 (void)setegid(PL_statbuf.st_gid);
a687059c 3194#else
fe14fcc3 3195#ifdef HAS_SETREGID
b28d0864 3196 (void)setregid((Gid_t)-1,PL_statbuf.st_gid);
85e6fe83
LW		 3197#else
3198#ifdef HAS_SETRESGID
b28d0864 3199 (void)setresgid((Gid_t)-1,PL_statbuf.st_gid,(Gid_t)-1);
a687059c 3200#else
b28d0864 3201 PerlProc_setgid(PL_statbuf.st_gid);
a687059c
LW		 3202#endif
3203#endif
85e6fe83 3204#endif
b28d0864 3205 if (PerlProc_getegid() != PL_statbuf.st_gid)
cea2e8a9 3206 Perl_croak(aTHX_ "Can't do setegid!\n");
83025b21 3207 }
b28d0864
NIS		 3208 if (PL_statbuf.st_mode & S_ISUID) {
3209 if (PL_statbuf.st_uid != PL_euid)
fe14fcc3 3210#ifdef HAS_SETEUID
b28d0864 3211 (void)seteuid(PL_statbuf.st_uid); /* all that for this */
a687059c 3212#else
fe14fcc3 3213#ifdef HAS_SETREUID
b28d0864 3214 (void)setreuid((Uid_t)-1,PL_statbuf.st_uid);
85e6fe83
LW		 3215#else
3216#ifdef HAS_SETRESUID
b28d0864 3217 (void)setresuid((Uid_t)-1,PL_statbuf.st_uid,(Uid_t)-1);
a687059c 3218#else
b28d0864 3219 PerlProc_setuid(PL_statbuf.st_uid);
a687059c
LW		 3220#endif
3221#endif
85e6fe83 3222#endif
b28d0864 3223 if (PerlProc_geteuid() != PL_statbuf.st_uid)
cea2e8a9 3224 Perl_croak(aTHX_ "Can't do seteuid!\n");
a687059c 3225 }
b28d0864 3226 else if (PL_uid) { /* oops, mustn't run as root */
fe14fcc3 3227#ifdef HAS_SETEUID
b28d0864 3228 (void)seteuid((Uid_t)PL_uid);
a687059c 3229#else
fe14fcc3 3230#ifdef HAS_SETREUID
b28d0864 3231 (void)setreuid((Uid_t)-1,(Uid_t)PL_uid);
a687059c 3232#else
85e6fe83 3233#ifdef HAS_SETRESUID
b28d0864 3234 (void)setresuid((Uid_t)-1,(Uid_t)PL_uid,(Uid_t)-1);
85e6fe83 3235#else
b28d0864 3236 PerlProc_setuid((Uid_t)PL_uid);
85e6fe83 3237#endif
a687059c
LW		 3238#endif
3239#endif
b28d0864 3240 if (PerlProc_geteuid() != PL_uid)
cea2e8a9 3241 Perl_croak(aTHX_ "Can't do seteuid!\n");
83025b21 3242 }
748a9306 3243 init_ids();
b28d0864 3244 if (!cando(S_IXUSR,TRUE,&PL_statbuf))
cea2e8a9 3245 Perl_croak(aTHX_ "Permission denied\n"); /* they can't do this */
13281fa4
LW		 3246 }
3247#ifdef IAMSUID
6b88bc9c 3248 else if (PL_preprocess)
cea2e8a9 3249 Perl_croak(aTHX_ "-P not allowed for setuid/setgid script\n");
96436eeb 3250 else if (fdscript >= 0)
cea2e8a9 3251 Perl_croak(aTHX_ "fd script not allowed in suidperl\n");
13281fa4 3252 else
cea2e8a9 3253 Perl_croak(aTHX_ "Script is not setuid/setgid in suidperl\n");
96436eeb 3254
3255 /* We absolutely must clear out any saved ids here, so we */
3256 /* exec the real perl, substituting fd script for scriptname. */
3257 /* (We pass script name as "subdir" of fd, which perl will grok.) */
b28d0864
NIS		 3258 PerlIO_rewind(PL_rsfp);
3259 PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0); /* just in case rewind didn't */
6b88bc9c
GS		 3260 for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;
3261 if (!PL_origargv[which])
cea2e8a9
GS		 3262 Perl_croak(aTHX_ "Permission denied");
3263 PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s",
6b88bc9c 3264 PerlIO_fileno(PL_rsfp), PL_origargv[which]));
96436eeb 3265#if defined(HAS_FCNTL) && defined(F_SETFD)
b28d0864 3266 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0); /* ensure no close-on-exec */
96436eeb 3267#endif
a7cb1f99 3268 PerlProc_execv(Perl_form(aTHX_ "%s/perl"PERL_FS_VER_FMT, BIN_EXP,
273cf8d1
GS		 3269 (int)PERL_REVISION, (int)PERL_VERSION,
3270 (int)PERL_SUBVERSION), PL_origargv);/* try again */
cea2e8a9 3271 Perl_croak(aTHX_ "Can't do setuid\n");
13281fa4 3272#endif /* IAMSUID */
a687059c 3273#else /* !DOSUID */
3280af22 3274 if (PL_euid != PL_uid || PL_egid != PL_gid) { /* (suidperl doesn't exist, in fact) */
a687059c 3275#ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
b28d0864
NIS		 3276 PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf); /* may be either wrapped or real suid */
3277 if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
a687059c 3278 ||
b28d0864 3279 (PL_egid != PL_gid && PL_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
a687059c 3280 )
b28d0864 3281 if (!PL_do_undump)
cea2e8a9 3282 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
a687059c
LW		 3283FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
3284#endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
3285 /* not set-id, must be wrapped */
a687059c 3286 }
13281fa4 3287#endif /* DOSUID */
79072805 3288}
13281fa4 3289
76e3520e 3290STATIC void
cea2e8a9 3291S_find_beginning(pTHX)
79072805 3292{
6e72f9df 3293 register char *s, *s2;
5b7ea690
JH		 3294#ifdef MACOS_TRADITIONAL
3295 int maclines = 0;
3296#endif
33b78306
LW		 3297
3298 /* skip forward in input to the real script? */
3299
bbce6d69 3300 forbid_setid("-x");
bf4acbe4 3301#ifdef MACOS_TRADITIONAL
084592ab 3302 /* Since the Mac OS does not honor #! arguments for us, we do it ourselves */
ac27b0f5 3303
bf4acbe4
GS		 3304 while (PL_doextract || gMacPerl_AlwaysExtract) {
3305 if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
3306 if (!gMacPerl_AlwaysExtract)
3307 Perl_croak(aTHX_ "No Perl script found in input\n");
5b7ea690 3308
bf4acbe4
GS		 3309 if (PL_doextract) /* require explicit override ? */
3310 if (!OverrideExtract(PL_origfilename))
3311 Perl_croak(aTHX_ "User aborted script\n");
3312 else
3313 PL_doextract = FALSE;
5b7ea690 3314
bf4acbe4
GS		 3315 /* Pater peccavi, file does not have #! */
3316 PerlIO_rewind(PL_rsfp);
5b7ea690 3317
bf4acbe4
GS		 3318 break;
3319 }
3320#else
3280af22
NIS		 3321 while (PL_doextract) {
3322 if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch)
cea2e8a9 3323 Perl_croak(aTHX_ "No Perl script found in input\n");
bf4acbe4 3324#endif
4f0c37ba
IZ		 3325 s2 = s;
3326 if (*s == '#' && s[1] == '!' && ((s = instr(s,"perl")) || (s = instr(s2,"PERL")))) {
3280af22
NIS		 3327 PerlIO_ungetc(PL_rsfp, '\n'); /* to keep line count right */
3328 PL_doextract = FALSE;
6e72f9df 3329 while (*s && !(isSPACE (*s) || *s == '#')) s++;
3330 s2 = s;
3331 while (*s == ' ' || *s == '\t') s++;
3332 if (*s++ == '-') {
3333 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
3334 if (strnEQ(s2-4,"perl",4))
3335 /*SUPPRESS 530*/
155aba94
GS		 3336 while ((s = moreswitches(s)))
3337 ;
33b78306 3338 }
95e8664e 3339#ifdef MACOS_TRADITIONAL
5b7ea690
JH		 3340 /* We are always searching for the #!perl line in MacPerl,
3341 * so if we find it, still keep the line count correct
3342 * by counting lines we already skipped over
3343 */
3344 for (; maclines > 0 ; maclines--)
3345 PerlIO_ungetc(PL_rsfp, '\n');
3346
95e8664e 3347 break;
5b7ea690
JH		 3348
3349 /* gMacPerl_AlwaysExtract is false in MPW tool */
3350 } else if (gMacPerl_AlwaysExtract) {
3351 ++maclines;
95e8664e 3352#endif
83025b21
LW		 3353 }
3354 }
3355}
3356
afe37c7d 3357
76e3520e 3358STATIC void
cea2e8a9 3359S_init_ids(pTHX)
352d5a3a 3360{
d8eceb89
JH		 3361 PL_uid = PerlProc_getuid();
3362 PL_euid = PerlProc_geteuid();
3363 PL_gid = PerlProc_getgid();
3364 PL_egid = PerlProc_getegid();
748a9306 3365#ifdef VMS
b28d0864
NIS		 3366 PL_uid |= PL_gid << 16;
3367 PL_euid |= PL_egid << 16;
748a9306 3368#endif
3280af22 3369 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
748a9306 3370}
79072805 3371
76e3520e 3372STATIC void
cea2e8a9 3373S_forbid_setid(pTHX_ char *s)
bbce6d69 3374{
3280af22 3375 if (PL_euid != PL_uid)
cea2e8a9 3376 Perl_croak(aTHX_ "No %s allowed while running setuid", s);
3280af22 3377 if (PL_egid != PL_gid)
cea2e8a9 3378 Perl_croak(aTHX_ "No %s allowed while running setgid", s);
bbce6d69 3379}
3380
1ee4443e
IZ		 3381void
3382Perl_init_debugger(pTHX)
748a9306 3383{
1ee4443e
IZ		 3384 HV *ostash = PL_curstash;
3385
3280af22
NIS		 3386 PL_curstash = PL_debstash;
3387 PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
3388 AvREAL_off(PL_dbargs);
3389 PL_DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
3390 PL_DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
3391 PL_DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
1ee4443e 3392 sv_upgrade(GvSV(PL_DBsub), SVt_IV); /* IVX accessed if PERLDB_SUB_NN */
3280af22 3393 PL_DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
ac27b0f5 3394 sv_setiv(PL_DBsingle, 0);
3280af22 3395 PL_DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
ac27b0f5 3396 sv_setiv(PL_DBtrace, 0);
3280af22 3397 PL_DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
ac27b0f5 3398 sv_setiv(PL_DBsignal, 0);
1ee4443e 3399 PL_curstash = ostash;
352d5a3a
LW		 3400}
3401
2ce36478
SM		 3402#ifndef STRESS_REALLOC
3403#define REASONABLE(size) (size)
3404#else
3405#define REASONABLE(size) (1) /* unreasonable */
3406#endif
3407
11343788 3408void
cea2e8a9 3409Perl_init_stacks(pTHX)
79072805 3410{
e336de0d 3411 /* start with 128-item stack and 8K cxstack */
3280af22 3412 PL_curstackinfo = new_stackinfo(REASONABLE(128),
e336de0d 3413 REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
3280af22
NIS		 3414 PL_curstackinfo->si_type = PERLSI_MAIN;
3415 PL_curstack = PL_curstackinfo->si_stack;
3416 PL_mainstack = PL_curstack; /* remember in case we switch stacks */
79072805 3417
3280af22
NIS		 3418 PL_stack_base = AvARRAY(PL_curstack);
3419 PL_stack_sp = PL_stack_base;
3420 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
8990e307 3421
3280af22
NIS		 3422 New(50,PL_tmps_stack,REASONABLE(128),SV*);
3423 PL_tmps_floor = -1;
3424 PL_tmps_ix = -1;
3425 PL_tmps_max = REASONABLE(128);
8990e307 3426
3280af22
NIS		 3427 New(54,PL_markstack,REASONABLE(32),I32);
3428 PL_markstack_ptr = PL_markstack;
3429 PL_markstack_max = PL_markstack + REASONABLE(32);
79072805 3430
ce2f7c3b 3431 SET_MARK_OFFSET;
e336de0d 3432
3280af22
NIS		 3433 New(54,PL_scopestack,REASONABLE(32),I32);
3434 PL_scopestack_ix = 0;
3435 PL_scopestack_max = REASONABLE(32);
79072805 3436
3280af22
NIS		 3437 New(54,PL_savestack,REASONABLE(128),ANY);
3438 PL_savestack_ix = 0;
3439 PL_savestack_max = REASONABLE(128);
79072805 3440
3280af22
NIS		 3441 New(54,PL_retstack,REASONABLE(16),OP*);
3442 PL_retstack_ix = 0;
3443 PL_retstack_max = REASONABLE(16);
378cc40b 3444}
33b78306 3445
2ce36478
SM		 3446#undef REASONABLE
3447
76e3520e 3448STATIC void
cea2e8a9 3449S_nuke_stacks(pTHX)
6e72f9df 3450{
3280af22
NIS		 3451 while (PL_curstackinfo->si_next)
3452 PL_curstackinfo = PL_curstackinfo->si_next;
3453 while (PL_curstackinfo) {
3454 PERL_SI *p = PL_curstackinfo->si_prev;
bac4b2ad 3455 /* curstackinfo->si_stack got nuked by sv_free_arenas() */
3280af22
NIS		 3456 Safefree(PL_curstackinfo->si_cxstack);
3457 Safefree(PL_curstackinfo);
3458 PL_curstackinfo = p;
e336de0d 3459 }
3280af22
NIS		 3460 Safefree(PL_tmps_stack);
3461 Safefree(PL_markstack);
3462 Safefree(PL_scopestack);
3463 Safefree(PL_savestack);
3464 Safefree(PL_retstack);
378cc40b 3465}
33b78306 3466
76e3520e 3467STATIC void
cea2e8a9 3468S_init_lexer(pTHX)
8990e307 3469{
06039172 3470 PerlIO *tmpfp;
3280af22
NIS		 3471 tmpfp = PL_rsfp;
3472 PL_rsfp = Nullfp;
3473 lex_start(PL_linestr);
3474 PL_rsfp = tmpfp;
79cb57f6 3475 PL_subname = newSVpvn("main",4);
8990e307
LW		 3476}
3477
76e3520e 3478STATIC void
cea2e8a9 3479S_init_predump_symbols(pTHX)
45d8adaa 3480{
93a17b20 3481 GV *tmpgv;
af8c498a 3482 IO *io;
79072805 3483
864dbfa3 3484 sv_setpvn(get_sv("\"", TRUE), " ", 1);
3280af22
NIS		 3485 PL_stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
3486 GvMULTI_on(PL_stdingv);
af8c498a 3487 io = GvIOp(PL_stdingv);
a04651f4 3488 IoTYPE(io) = IoTYPE_RDONLY;
af8c498a 3489 IoIFP(io) = PerlIO_stdin();
adbc6bb1 3490 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
a5f75d66 3491 GvMULTI_on(tmpgv);
af8c498a 3492 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
79072805 3493
85e6fe83 3494 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
a5f75d66 3495 GvMULTI_on(tmpgv);
af8c498a 3496 io = GvIOp(tmpgv);
a04651f4 3497 IoTYPE(io) = IoTYPE_WRONLY;
af8c498a 3498 IoOFP(io) = IoIFP(io) = PerlIO_stdout();
4633a7c4 3499 setdefout(tmpgv);
adbc6bb1 3500 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
a5f75d66 3501 GvMULTI_on(tmpgv);
af8c498a 3502 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
79072805 3503
bf49b057
GS		 3504 PL_stderrgv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
3505 GvMULTI_on(PL_stderrgv);
3506 io = GvIOp(PL_stderrgv);
a04651f4 3507 IoTYPE(io) = IoTYPE_WRONLY;
af8c498a 3508 IoOFP(io) = IoIFP(io) = PerlIO_stderr();
adbc6bb1 3509 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
a5f75d66 3510 GvMULTI_on(tmpgv);
af8c498a 3511 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
79072805 3512
3280af22 3513 PL_statname = NEWSV(66,0); /* last filename we did stat on */
ab821d7f 3514
bf4acbe4
GS		 3515 if (PL_osname)
3516 Safefree(PL_osname);
3517 PL_osname = savepv(OSNAME);
79072805 3518}
33b78306 3519
a11ec5a9
RGS		 3520void
3521Perl_init_argv_symbols(pTHX_ register int argc, register char **argv)
33b78306 3522{
79072805 3523 char *s;
79072805 3524 argc--,argv++; /* skip name of script */
3280af22 3525 if (PL_doswitches) {
79072805
LW		 3526 for (; argc > 0 && **argv == '-'; argc--,argv++) {
3527 if (!argv[0][1])
3528 break;
379d538a 3529 if (argv[0][1] == '-' && !argv[0][2]) {
79072805
LW		 3530 argc--,argv++;
3531 break;
3532 }
155aba94 3533 if ((s = strchr(argv[0], '='))) {
79072805 3534 *s++ = '\0';
85e6fe83 3535 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
79072805
LW		 3536 }
3537 else
85e6fe83 3538 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
fe14fcc3 3539 }
79072805 3540 }
a11ec5a9
RGS		 3541 if ((PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV))) {
3542 GvMULTI_on(PL_argvgv);
3543 (void)gv_AVadd(PL_argvgv);
3544 av_clear(GvAVn(PL_argvgv));
3545 for (; argc > 0; argc--,argv++) {
3546 SV *sv = newSVpv(argv[0],0);
3547 av_push(GvAVn(PL_argvgv),sv);
3548 if (PL_widesyscalls)
3549 (void)sv_utf8_decode(sv);
3550 }
3551 }
3552}
3553
04fee9b5
NIS		 3554#ifdef HAS_PROCSELFEXE
3555/* This is a function so that we don't hold on to MAXPATHLEN
8338e367 3556 bytes of stack longer than necessary
04fee9b5
NIS		 3557 */
3558STATIC void
3559S_procself_val(pTHX_ SV *sv, char *arg0)
3560{
3561 char buf[MAXPATHLEN];
d13a6521 3562 int len = readlink(PROCSELFEXE_PATH, buf, sizeof(buf) - 1);
75745e22
TJ		 3563
3564 /* On Playstation2 Linux V1.0 (kernel 2.2.1) readlink(/proc/self/exe)
3565 includes a spurious NUL which will cause $^X to fail in system
3566 or backticks (this will prevent extensions from being built and
3567 many tests from working). readlink is not meant to add a NUL.
3568 Normal readlink works fine.
3569 */
3570 if (len > 0 && buf[len-1] == '\0') {
3571 len--;
3572 }
3573
d103ec31
JH		 3574 /* FreeBSD's implementation is acknowledged to be imperfect, sometimes
3575 returning the text "unknown" from the readlink rather than the path
78cb7c00 3576 to the executable (or returning an error from the readlink). Any valid
d103ec31
JH		 3577 path has a '/' in it somewhere, so use that to validate the result.
3578 See http://www.freebsd.org/cgi/query-pr.cgi?pr=35703
3579 */
78cb7c00 3580 if (len > 0 && memchr(buf, '/', len)) {
04fee9b5
NIS		 3581 sv_setpvn(sv,buf,len);
3582 }
3583 else {
3584 sv_setpv(sv,arg0);
3585 }
3586}
3587#endif /* HAS_PROCSELFEXE */
3588
a11ec5a9
RGS		 3589STATIC void
3590S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
3591{
3592 char *s;
3593 SV *sv;
3594 GV* tmpgv;
a11ec5a9 3595
3280af22
NIS		 3596 PL_toptarget = NEWSV(0,0);
3597 sv_upgrade(PL_toptarget, SVt_PVFM);
3598 sv_setpvn(PL_toptarget, "", 0);
3599 PL_bodytarget = NEWSV(0,0);
3600 sv_upgrade(PL_bodytarget, SVt_PVFM);
3601 sv_setpvn(PL_bodytarget, "", 0);
3602 PL_formtarget = PL_bodytarget;
79072805 3603
bbce6d69 3604 TAINT;
a11ec5a9
RGS		 3605
3606 init_argv_symbols(argc,argv);
3607
155aba94 3608 if ((tmpgv = gv_fetchpv("0",TRUE, SVt_PV))) {
bf4acbe4
GS		 3609#ifdef MACOS_TRADITIONAL
3610 /* $0 is not majick on a Mac */
3611 sv_setpv(GvSV(tmpgv),MacPerl_MPWFileName(PL_origfilename));
3612#else
3280af22 3613 sv_setpv(GvSV(tmpgv),PL_origfilename);
79072805 3614 magicname("0", "0", 1);
bf4acbe4 3615#endif
79072805 3616 }
04fee9b5
NIS		 3617 if ((tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))) {/* $^X */
3618#ifdef HAS_PROCSELFEXE
3619 S_procself_val(aTHX_ GvSV(tmpgv), PL_origargv[0]);
3620#else
8338e367 3621#ifdef OS2
23da6c43 3622 sv_setpv(GvSV(tmpgv), os2_execname(aTHX));
8338e367
JH		 3623#else
3624 sv_setpv(GvSV(tmpgv),PL_origargv[0]);
3625#endif
04fee9b5
NIS		 3626#endif
3627 }
155aba94 3628 if ((PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV))) {
79072805 3629 HV *hv;
3280af22
NIS		 3630 GvMULTI_on(PL_envgv);
3631 hv = GvHVn(PL_envgv);
14befaf4 3632 hv_magic(hv, Nullgv, PERL_MAGIC_env);
fa6a1c44 3633#ifdef USE_ENVIRON_ARRAY
4633a7c4
LW		 3634 /* Note that if the supplied env parameter is actually a copy
3635 of the global environ then it may now point to free'd memory
3636 if the environment has been modified since. To avoid this
3637 problem we treat env==NULL as meaning 'use the default'
3638 */
3639 if (!env)
3640 env = environ;
4efc5df6
GS		 3641 if (env != environ
3642# ifdef USE_ITHREADS
3643 && PL_curinterp == aTHX
3644# endif
3645 )
3646 {
79072805 3647 environ[0] = Nullch;
4efc5df6 3648 }
764df951
IZ		 3649 if (env)
3650 for (; *env; env++) {
93a17b20 3651 if (!(s = strchr(*env,'=')))
79072805 3652 continue;
60ce6247 3653#if defined(MSDOS)
61968511 3654 *s = '\0';
137443ea 3655 (void)strupr(*env);
61968511 3656 *s = '=';
137443ea 3657#endif
61968511 3658 sv = newSVpv(s+1, 0);
79072805 3659 (void)hv_store(hv, *env, s - *env, sv, 0);
61968511
GA		 3660 if (env != environ)
3661 mg_set(sv);
764df951 3662 }
103a7189 3663#endif /* USE_ENVIRON_ARRAY */
79072805 3664 }
bbce6d69 3665 TAINT_NOT;
306196c3
MS		 3666 if ((tmpgv = gv_fetchpv("$",TRUE, SVt_PV))) {
3667 SvREADONLY_off(GvSV(tmpgv));
7766f137 3668 sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
306196c3
MS		 3669 SvREADONLY_on(GvSV(tmpgv));
3670 }
5b7ea690
JH		 3671#ifdef THREADS_HAVE_PIDS
3672 PL_ppid = (IV)getppid();
3673#endif
2710853f
MJD		 3674
3675 /* touch @F array to prevent spurious warnings 20020415 MJD */
3676 if (PL_minus_a) {
3677 (void) get_av("main::F", TRUE | GV_ADDMULTI);
3678 }
3679 /* touch @- and @+ arrays to prevent spurious warnings 20020415 MJD */
3680 (void) get_av("main::-", TRUE | GV_ADDMULTI);
3681 (void) get_av("main::+", TRUE | GV_ADDMULTI);
33b78306 3682}
34de22dd 3683
76e3520e 3684STATIC void
cea2e8a9 3685S_init_perllib(pTHX)
34de22dd 3686{
85e6fe83 3687 char *s;
3280af22 3688 if (!PL_tainting) {
552a7a9b 3689#ifndef VMS
76e3520e 3690 s = PerlEnv_getenv("PERL5LIB");
85e6fe83 3691 if (s)
9c8a64f0 3692 incpush(s, TRUE, TRUE);
85e6fe83 3693 else
9c8a64f0 3694 incpush(PerlEnv_getenv("PERLLIB"), FALSE, FALSE);
552a7a9b 3695#else /* VMS */
3696 /* Treat PERL5?LIB as a possible search list logical name -- the
3697 * "natural" VMS idiom for a Unix path string. We allow each
3698 * element to be a set of |-separated directories for compatibility.
3699 */
3700 char buf[256];
3701 int idx = 0;
3702 if (my_trnlnm("PERL5LIB",buf,0))
9c8a64f0 3703 do { incpush(buf,TRUE,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
552a7a9b 3704 else
9c8a64f0 3705 while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE,FALSE);
552a7a9b 3706#endif /* VMS */
85e6fe83 3707 }
34de22dd 3708
c90c0ff4 3709/* Use the ~-expanded versions of APPLLIB (undocumented),
65f19062 3710 ARCHLIB PRIVLIB SITEARCH SITELIB VENDORARCH and VENDORLIB
df5cef82 3711*/
4633a7c4 3712#ifdef APPLLIB_EXP
9c8a64f0 3713 incpush(APPLLIB_EXP, TRUE, TRUE);
16d20bd9 3714#endif
4633a7c4 3715
fed7345c 3716#ifdef ARCHLIB_EXP
9c8a64f0 3717 incpush(ARCHLIB_EXP, FALSE, FALSE);
a0d0e21e 3718#endif
bf4acbe4
GS		 3719#ifdef MACOS_TRADITIONAL
3720 {
c623ac67 3721 Stat_t tmpstatbuf;
bf4acbe4
GS		 3722 SV * privdir = NEWSV(55, 0);
3723 char * macperl = PerlEnv_getenv("MACPERL");
3724
3725 if (!macperl)
3726 macperl = "";
3727
3728 Perl_sv_setpvf(aTHX_ privdir, "%slib:", macperl);
3729 if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode))
3730 incpush(SvPVX(privdir), TRUE, FALSE);
3731 Perl_sv_setpvf(aTHX_ privdir, "%ssite_perl:", macperl);
3732 if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode))
3733 incpush(SvPVX(privdir), TRUE, FALSE);
ac27b0f5 3734
bf4acbe4
GS		 3735 SvREFCNT_dec(privdir);
3736 }
3737 if (!PL_tainting)
3738 incpush(":", FALSE, FALSE);
3739#else
fed7345c 3740#ifndef PRIVLIB_EXP
65f19062 3741# define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
34de22dd 3742#endif
ac27b0f5 3743#if defined(WIN32)
9c8a64f0 3744 incpush(PRIVLIB_EXP, TRUE, FALSE);
00dc2f4f 3745#else
9c8a64f0 3746 incpush(PRIVLIB_EXP, FALSE, FALSE);
00dc2f4f 3747#endif
4633a7c4 3748
65f19062 3749#ifdef SITEARCH_EXP
3b290362
GS		 3750 /* sitearch is always relative to sitelib on Windows for
3751 * DLL-based path intuition to work correctly */
3752# if !defined(WIN32)
9c8a64f0 3753 incpush(SITEARCH_EXP, FALSE, FALSE);
65f19062
GS		 3754# endif
3755#endif
3756
4633a7c4 3757#ifdef SITELIB_EXP
65f19062 3758# if defined(WIN32)
9c8a64f0 3759 incpush(SITELIB_EXP, TRUE, FALSE); /* this picks up sitearch as well */
65f19062 3760# else
9c8a64f0 3761 incpush(SITELIB_EXP, FALSE, FALSE);
65f19062
GS		 3762# endif
3763#endif
189d1e8d 3764
65f19062 3765#ifdef SITELIB_STEM /* Search for version-specific dirs below here */
9c8a64f0 3766 incpush(SITELIB_STEM, FALSE, TRUE);
81c6dfba 3767#endif
65f19062
GS		 3768
3769#ifdef PERL_VENDORARCH_EXP
4ea817c6 3770 /* vendorarch is always relative to vendorlib on Windows for
3b290362
GS		 3771 * DLL-based path intuition to work correctly */
3772# if !defined(WIN32)
9c8a64f0 3773 incpush(PERL_VENDORARCH_EXP, FALSE, FALSE);
65f19062 3774# endif
4b03c463 3775#endif
65f19062
GS		 3776
3777#ifdef PERL_VENDORLIB_EXP
3778# if defined(WIN32)
9c8a64f0 3779 incpush(PERL_VENDORLIB_EXP, TRUE, FALSE); /* this picks up vendorarch as well */
65f19062 3780# else
9c8a64f0 3781 incpush(PERL_VENDORLIB_EXP, FALSE, FALSE);
65f19062 3782# endif
a3635516 3783#endif
65f19062
GS		 3784
3785#ifdef PERL_VENDORLIB_STEM /* Search for version-specific dirs below here */
9c8a64f0 3786 incpush(PERL_VENDORLIB_STEM, FALSE, TRUE);
00dc2f4f 3787#endif
65f19062 3788
3b777bb4
GS		 3789#ifdef PERL_OTHERLIBDIRS
3790 incpush(PERL_OTHERLIBDIRS, TRUE, TRUE);
3791#endif
3792
3280af22 3793 if (!PL_tainting)
9c8a64f0 3794 incpush(".", FALSE, FALSE);
bf4acbe4 3795#endif /* MACOS_TRADITIONAL */
774d564b 3796}
3797
ed79a026 3798#if defined(DOSISH) || defined(EPOC)
774d564b 3799# define PERLLIB_SEP ';'
3800#else
3801# if defined(VMS)
3802# define PERLLIB_SEP '|'
3803# else
bf4acbe4
GS		 3804# if defined(MACOS_TRADITIONAL)
3805# define PERLLIB_SEP ','
3806# else
3807# define PERLLIB_SEP ':'
3808# endif
774d564b 3809# endif
3810#endif
3811#ifndef PERLLIB_MANGLE
3812# define PERLLIB_MANGLE(s,n) (s)
ac27b0f5 3813#endif
774d564b 3814
76e3520e 3815STATIC void
9c8a64f0 3816S_incpush(pTHX_ char *p, int addsubdirs, int addoldvers)
774d564b 3817{
3818 SV *subdir = Nullsv;
774d564b 3819
3b290362 3820 if (!p || !*p)
774d564b 3821 return;
3822
9c8a64f0 3823 if (addsubdirs || addoldvers) {
00db4c45 3824 subdir = sv_newmortal();
774d564b 3825 }
3826
3827 /* Break at all separators */
3828 while (p && *p) {
8c52afec 3829 SV *libdir = NEWSV(55,0);
774d564b 3830 char *s;
3831
3832 /* skip any consecutive separators */
3833 while ( *p == PERLLIB_SEP ) {
3834 /* Uncomment the next line for PATH semantics */
79cb57f6 3835 /* av_push(GvAVn(PL_incgv), newSVpvn(".", 1)); */
774d564b 3836 p++;
3837 }
3838
3839 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
3840 sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
3841 (STRLEN)(s - p));
3842 p = s + 1;
3843 }
3844 else {
3845 sv_setpv(libdir, PERLLIB_MANGLE(p, 0));
3846 p = Nullch; /* break out */
3847 }
bf4acbe4 3848#ifdef MACOS_TRADITIONAL
e69a2255
JH		 3849 if (!strchr(SvPVX(libdir), ':')) {
3850 char buf[256];
3851
3852 sv_setpv(libdir, MacPerl_CanonDir(SvPVX(libdir), buf, 0));
3853 }
bf4acbe4
GS		 3854 if (SvPVX(libdir)[SvCUR(libdir)-1] != ':')
3855 sv_catpv(libdir, ":");
3856#endif
774d564b 3857
3858 /*
3859 * BEFORE pushing libdir onto @INC we may first push version- and
3860 * archname-specific sub-directories.
3861 */
9c8a64f0 3862 if (addsubdirs || addoldvers) {
29d82f8d 3863#ifdef PERL_INC_VERSION_LIST
8353b874
GS		 3864 /* Configure terminates PERL_INC_VERSION_LIST with a NULL */
3865 const char *incverlist[] = { PERL_INC_VERSION_LIST };
29d82f8d
GS		 3866 const char **incver;
3867#endif
c623ac67 3868 Stat_t tmpstatbuf;
aa689395 3869#ifdef VMS
3870 char *unix;
3871 STRLEN len;
774d564b 3872
2d8e6c8d 3873 if ((unix = tounixspec_ts(SvPV(libdir,len),Nullch)) != Nullch) {
aa689395 3874 len = strlen(unix);
3875 while (unix[len-1] == '/') len--; /* Cosmetic */
3876 sv_usepvn(libdir,unix,len);
3877 }
3878 else
bf49b057 3879 PerlIO_printf(Perl_error_log,
aa689395 3880 "Failed to unixify @INC element \"%s\"\n",
2d8e6c8d 3881 SvPV(libdir,len));
aa689395 3882#endif
9c8a64f0 3883 if (addsubdirs) {
bf4acbe4
GS		 3884#ifdef MACOS_TRADITIONAL
3885#define PERL_AV_SUFFIX_FMT ""
084592ab
CN		 3886#define PERL_ARCH_FMT "%s:"
3887#define PERL_ARCH_FMT_PATH PERL_FS_VER_FMT PERL_AV_SUFFIX_FMT
bf4acbe4
GS		 3888#else
3889#define PERL_AV_SUFFIX_FMT "/"
3890#define PERL_ARCH_FMT "/%s"
084592ab 3891#define PERL_ARCH_FMT_PATH PERL_AV_SUFFIX_FMT PERL_FS_VER_FMT
bf4acbe4 3892#endif
9c8a64f0 3893 /* .../version/archname if -d .../version/archname */
084592ab 3894 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH PERL_ARCH_FMT,
9c8a64f0
GS		 3895 libdir,
3896 (int)PERL_REVISION, (int)PERL_VERSION,
3897 (int)PERL_SUBVERSION, ARCHNAME);
3898 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3899 S_ISDIR(tmpstatbuf.st_mode))
3900 av_push(GvAVn(PL_incgv), newSVsv(subdir));
4b03c463 3901
9c8a64f0 3902 /* .../version if -d .../version */
084592ab 3903 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH, libdir,
9c8a64f0
GS		 3904 (int)PERL_REVISION, (int)PERL_VERSION,
3905 (int)PERL_SUBVERSION);
3906 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3907 S_ISDIR(tmpstatbuf.st_mode))
3908 av_push(GvAVn(PL_incgv), newSVsv(subdir));
3909
3910 /* .../archname if -d .../archname */
bf4acbe4 3911 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, libdir, ARCHNAME);
29d82f8d
GS		 3912 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3913 S_ISDIR(tmpstatbuf.st_mode))
3914 av_push(GvAVn(PL_incgv), newSVsv(subdir));
29d82f8d 3915 }
9c8a64f0 3916
9c8a64f0 3917#ifdef PERL_INC_VERSION_LIST
ccc2aad8 3918 if (addoldvers) {
9c8a64f0
GS		 3919 for (incver = incverlist; *incver; incver++) {
3920 /* .../xxx if -d .../xxx */
bf4acbe4 3921 Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, libdir, *incver);
9c8a64f0
GS		 3922 if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
3923 S_ISDIR(tmpstatbuf.st_mode))
3924 av_push(GvAVn(PL_incgv), newSVsv(subdir));
3925 }
3926 }
29d82f8d 3927#endif
774d564b 3928 }
3929
3930 /* finally push this lib directory on the end of @INC */
3280af22 3931 av_push(GvAVn(PL_incgv), libdir);
774d564b 3932 }
34de22dd 3933}
93a17b20 3934
4d1ff10f 3935#ifdef USE_5005THREADS
76e3520e 3936STATIC struct perl_thread *
cea2e8a9 3937S_init_main_thread(pTHX)
199100c8 3938{
c5be433b 3939#if !defined(PERL_IMPLICIT_CONTEXT)
52e1cb5e 3940 struct perl_thread *thr;
cea2e8a9 3941#endif
199100c8
MB		 3942 XPV *xpv;
3943
52e1cb5e 3944 Newz(53, thr, 1, struct perl_thread);
533c011a 3945 PL_curcop = &PL_compiling;
c5be433b 3946 thr->interp = PERL_GET_INTERP;
199100c8 3947 thr->cvcache = newHV();
54b9620d 3948 thr->threadsv = newAV();
940cb80d 3949 /* thr->threadsvp is set when find_threadsv is called */
199100c8
MB		 3950 thr->specific = newAV();
3951 thr->flags = THRf_R_JOINABLE;
3952 MUTEX_INIT(&thr->mutex);
3953 /* Handcraft thrsv similarly to mess_sv */
533c011a 3954 New(53, PL_thrsv, 1, SV);
199100c8 3955 Newz(53, xpv, 1, XPV);
533c011a
NIS		 3956 SvFLAGS(PL_thrsv) = SVt_PV;
3957 SvANY(PL_thrsv) = (void*)xpv;
3958 SvREFCNT(PL_thrsv) = 1 << 30; /* practically infinite */
3959 SvPVX(PL_thrsv) = (char*)thr;
3960 SvCUR_set(PL_thrsv, sizeof(thr));
3961 SvLEN_set(PL_thrsv, sizeof(thr));
3962 *SvEND(PL_thrsv) = '\0'; /* in the trailing_nul field */
3963 thr->oursv = PL_thrsv;
3964 PL_chopset = " \n-";
3967c732 3965 PL_dumpindent = 4;
533c011a
NIS		 3966
3967 MUTEX_LOCK(&PL_threads_mutex);
3968 PL_nthreads++;
199100c8
MB		 3969 thr->tid = 0;
3970 thr->next = thr;
3971 thr->prev = thr;
8dcd6f7b 3972 thr->thr_done = 0;
533c011a 3973 MUTEX_UNLOCK(&PL_threads_mutex);
199100c8 3974
4b026b9e 3975#ifdef HAVE_THREAD_INTERN
4f63d024 3976 Perl_init_thread_intern(thr);
235db74f
GS		 3977#endif
3978
3979#ifdef SET_THREAD_SELF
3980 SET_THREAD_SELF(thr);
199100c8
MB		 3981#else
3982 thr->self = pthread_self();
235db74f 3983#endif /* SET_THREAD_SELF */
06d86050 3984 PERL_SET_THX(thr);
199100c8
MB		 3985
3986 /*
411caa50
JH		 3987 * These must come after the thread self setting
3988 * because sv_setpvn does SvTAINT and the taint
3989 * fields thread selfness being set.
199100c8 3990 */
533c011a
NIS		 3991 PL_toptarget = NEWSV(0,0);
3992 sv_upgrade(PL_toptarget, SVt_PVFM);
3993 sv_setpvn(PL_toptarget, "", 0);
3994 PL_bodytarget = NEWSV(0,0);
3995 sv_upgrade(PL_bodytarget, SVt_PVFM);
3996 sv_setpvn(PL_bodytarget, "", 0);
3997 PL_formtarget = PL_bodytarget;
79cb57f6 3998 thr->errsv = newSVpvn("", 0);
78857c3c 3999 (void) find_threadsv("@"); /* Ensure $@ is initialised early */
5c0ca799 4000
533c011a 4001 PL_maxscream = -1;
a2efc822 4002 PL_peepp = MEMBER_TO_FPTR(Perl_peep);
0b94c7bb
GS		 4003 PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp);
4004 PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags);
4005 PL_regint_start = MEMBER_TO_FPTR(Perl_re_intuit_start);
4006 PL_regint_string = MEMBER_TO_FPTR(Perl_re_intuit_string);
4007 PL_regfree = MEMBER_TO_FPTR(Perl_pregfree);
533c011a
NIS		 4008 PL_regindent = 0;
4009 PL_reginterp_cnt = 0;
5c0ca799 4010
199100c8
MB		 4011 return thr;
4012}
4d1ff10f 4013#endif /* USE_5005THREADS */
199100c8 4014
93a17b20 4015void
864dbfa3 4016Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
93a17b20 4017{
971a9dd3 4018 SV *atsv;
57843af0 4019 line_t oldline = CopLINE(PL_curcop);
312caa8e 4020 CV *cv;
22921e25 4021 STRLEN len;
6224f72b 4022 int ret;
db36c5a1 4023 dJMPENV;
93a17b20 4024
76e3520e 4025 while (AvFILL(paramList) >= 0) {
312caa8e 4026 cv = (CV*)av_shift(paramList);
5b7ea690
JH		 4027 if (PL_savebegin) {
4028 if (paramList == PL_beginav) {
059a8bb7 4029 /* save PL_beginav for compiler */
5b7ea690
JH		 4030 if (! PL_beginav_save)
4031 PL_beginav_save = newAV();
4032 av_push(PL_beginav_save, (SV*)cv);
4033 }
4034 else if (paramList == PL_checkav) {
4035 /* save PL_checkav for compiler */
4036 if (! PL_checkav_save)
4037 PL_checkav_save = newAV();
4038 av_push(PL_checkav_save, (SV*)cv);
4039 }
059a8bb7
JH		 4040 } else {
4041 SAVEFREESV(cv);
4042 }
14dd3ad8
GS		 4043#ifdef PERL_FLEXIBLE_EXCEPTIONS
4044 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_list_body), cv);
4045#else
4046 JMPENV_PUSH(ret);
4047#endif
6224f72b 4048 switch (ret) {
312caa8e 4049 case 0:
14dd3ad8
GS		 4050#ifndef PERL_FLEXIBLE_EXCEPTIONS
4051 call_list_body(cv);
4052#endif
971a9dd3 4053 atsv = ERRSV;
312caa8e
CS		 4054 (void)SvPV(atsv, len);
4055 if (len) {
971a9dd3 4056 STRLEN n_a;
312caa8e 4057 PL_curcop = &PL_compiling;
57843af0 4058 CopLINE_set(PL_curcop, oldline);
312caa8e
CS		 4059 if (paramList == PL_beginav)
4060 sv_catpv(atsv, "BEGIN failed--compilation aborted");
4061 else
4f25aa18
GS		 4062 Perl_sv_catpvf(aTHX_ atsv,
4063 "%s failed--call queue aborted",
7d30b5c4 4064 paramList == PL_checkav ? "CHECK"
4f25aa18
GS		 4065 : paramList == PL_initav ? "INIT"
4066 : "END");
312caa8e
CS		 4067 while (PL_scopestack_ix > oldscope)
4068 LEAVE;
14dd3ad8 4069 JMPENV_POP;
971a9dd3 4070 Perl_croak(aTHX_ "%s", SvPVx(atsv, n_a));
a0d0e21e 4071 }
85e6fe83 4072 break;
6224f72b 4073 case 1:
f86702cc 4074 STATUS_ALL_FAILURE;
85e6fe83 4075 /* FALL THROUGH */
6224f72b 4076 case 2:
85e6fe83 4077 /* my_exit() was called */
3280af22 4078 while (PL_scopestack_ix > oldscope)
2ae324a7 4079 LEAVE;
84902520 4080 FREETMPS;
3280af22 4081 PL_curstash = PL_defstash;
3280af22 4082 PL_curcop = &PL_compiling;
57843af0 4083 CopLINE_set(PL_curcop, oldline);
14dd3ad8 4084 JMPENV_POP;
cc3604b1 4085 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED)) {
3280af22 4086 if (paramList == PL_beginav)
cea2e8a9 4087 Perl_croak(aTHX_ "BEGIN failed--compilation aborted");
85e6fe83 4088 else
4f25aa18 4089 Perl_croak(aTHX_ "%s failed--call queue aborted",
7d30b5c4 4090 paramList == PL_checkav ? "CHECK"
4f25aa18
GS		 4091 : paramList == PL_initav ? "INIT"
4092 : "END");
85e6fe83 4093 }
f86702cc 4094 my_exit_jump();
85e6fe83 4095 /* NOTREACHED */
6224f72b 4096 case 3:
312caa8e
CS		 4097 if (PL_restartop) {
4098 PL_curcop = &PL_compiling;
57843af0 4099 CopLINE_set(PL_curcop, oldline);
312caa8e 4100 JMPENV_JUMP(3);
85e6fe83 4101 }
bf49b057 4102 PerlIO_printf(Perl_error_log, "panic: restartop\n");
312caa8e
CS		 4103 FREETMPS;
4104 break;
8990e307 4105 }
14dd3ad8 4106 JMPENV_POP;
93a17b20 4107 }
93a17b20 4108}
93a17b20 4109
14dd3ad8 4110#ifdef PERL_FLEXIBLE_EXCEPTIONS
312caa8e 4111STATIC void *
14dd3ad8 4112S_vcall_list_body(pTHX_ va_list args)
312caa8e 4113{
312caa8e 4114 CV *cv = va_arg(args, CV*);
14dd3ad8
GS		 4115 return call_list_body(cv);
4116}
4117#endif
312caa8e 4118
14dd3ad8
GS		 4119STATIC void *
4120S_call_list_body(pTHX_ CV *cv)
4121{
312caa8e 4122 PUSHMARK(PL_stack_sp);
864dbfa3 4123 call_sv((SV*)cv, G_EVAL|G_DISCARD);
312caa8e
CS		 4124 return NULL;
4125}
4126
f86702cc 4127void
864dbfa3 4128Perl_my_exit(pTHX_ U32 status)
f86702cc 4129{
8b73bbec 4130 DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
a863c7d1 4131 thr, (unsigned long) status));
f86702cc 4132 switch (status) {
4133 case 0:
4134 STATUS_ALL_SUCCESS;
4135 break;
4136 case 1:
4137 STATUS_ALL_FAILURE;
4138 break;
4139 default:
4140 STATUS_NATIVE_SET(status);
4141 break;
4142 }
4143 my_exit_jump();
4144}
4145
4146void
864dbfa3 4147Perl_my_failure_exit(pTHX)
f86702cc 4148{
4149#ifdef VMS
4150 if (vaxc$errno & 1) {
4fdae800 4151 if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
4152 STATUS_NATIVE_SET(44);
f86702cc 4153 }
4154 else {
ff0cee69 4155 if (!vaxc$errno && errno) /* unlikely */
4fdae800 4156 STATUS_NATIVE_SET(44);
f86702cc 4157 else
4fdae800 4158 STATUS_NATIVE_SET(vaxc$errno);
f86702cc 4159 }
4160#else
9b599b2a 4161 int exitstatus;
f86702cc 4162 if (errno & 255)
4163 STATUS_POSIX_SET(errno);
9b599b2a 4164 else {
ac27b0f5 4165 exitstatus = STATUS_POSIX >> 8;
9b599b2a
GS		 4166 if (exitstatus & 255)
4167 STATUS_POSIX_SET(exitstatus);
4168 else
4169 STATUS_POSIX_SET(255);
4170 }
f86702cc 4171#endif
4172 my_exit_jump();
93a17b20
LW		 4173}
4174
76e3520e 4175STATIC void
cea2e8a9 4176S_my_exit_jump(pTHX)
f86702cc 4177{
c09156bb 4178 register PERL_CONTEXT *cx;
f86702cc 4179 I32 gimme;
4180 SV **newsp;
4181
3280af22
NIS		 4182 if (PL_e_script) {
4183 SvREFCNT_dec(PL_e_script);
4184 PL_e_script = Nullsv;
f86702cc 4185 }
4186
3280af22 4187 POPSTACK_TO(PL_mainstack);
f86702cc 4188 if (cxstack_ix >= 0) {
4189 if (cxstack_ix > 0)
4190 dounwind(0);
3280af22 4191 POPBLOCK(cx,PL_curpm);
f86702cc 4192 LEAVE;
4193 }
ff0cee69 4194
6224f72b 4195 JMPENV_JUMP(2);
f86702cc 4196}
873ef191 4197
0cb96387 4198static I32
acfe0abc 4199read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen)
873ef191
GS		 4200{
4201 char *p, *nl;
3280af22 4202 p = SvPVX(PL_e_script);
873ef191 4203 nl = strchr(p, '\n');
3280af22 4204 nl = (nl) ? nl+1 : SvEND(PL_e_script);
7dfe3f66 4205 if (nl-p == 0) {
0cb96387 4206 filter_del(read_e_script);
873ef191 4207 return 0;
7dfe3f66 4208 }
873ef191 4209 sv_catpvn(buf_sv, p, nl-p);
3280af22 4210 sv_chop(PL_e_script, nl);
873ef191
GS		 4211 return 1;
4212}
Unnamed repository; edit this file 'description' to name the repository.