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