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