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