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