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