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
Re: [perl #20920] Segmentation fault ("Safe Signal" queue problem?)
[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':
06492da6 1027 case 'A':
155aba94 1028 if ((s = moreswitches(s)))
6224f72b
GS		 1029 goto reswitch;
1030 break;
33b78306 1031
1dbad523 1032 case 't':
317ea90d
MS		 1033 if( !PL_tainting ) {
1034 PL_taint_warn = TRUE;
1035 PL_tainting = TRUE;
1036 }
1037 s++;
1038 goto reswitch;
6224f72b 1039 case 'T':
3280af22 1040 PL_tainting = TRUE;
317ea90d 1041 PL_taint_warn = FALSE;
6224f72b
GS		 1042 s++;
1043 goto reswitch;
f86702cc 1044
6224f72b 1045 case 'e':
bf4acbe4
GS		 1046#ifdef MACOS_TRADITIONAL
1047 /* ignore -e for Dev:Pseudo argument */
1048 if (argv[1] && !strcmp(argv[1], "Dev:Pseudo"))
e55ac0fa 1049 break;
bf4acbe4 1050#endif
3280af22 1051 if (PL_euid != PL_uid || PL_egid != PL_gid)
cea2e8a9 1052 Perl_croak(aTHX_ "No -e allowed in setuid scripts");
3280af22 1053 if (!PL_e_script) {
79cb57f6 1054 PL_e_script = newSVpvn("",0);
0cb96387 1055 filter_add(read_e_script, NULL);
6224f72b
GS		 1056 }
1057 if (*++s)
3280af22 1058 sv_catpv(PL_e_script, s);
6224f72b 1059 else if (argv[1]) {
3280af22 1060 sv_catpv(PL_e_script, argv[1]);
6224f72b
GS		 1061 argc--,argv++;
1062 }
1063 else
cea2e8a9 1064 Perl_croak(aTHX_ "No code specified for -e");
3280af22 1065 sv_catpv(PL_e_script, "\n");
6224f72b 1066 break;
afe37c7d 1067
6224f72b
GS		 1068 case 'I': /* -I handled both here and in moreswitches() */
1069 forbid_setid("-I");
1070 if (!*++s && (s=argv[1]) != Nullch) {
1071 argc--,argv++;
1072 }
6224f72b 1073 if (s && *s) {
0df16ed7
GS		 1074 char *p;
1075 STRLEN len = strlen(s);
1076 p = savepvn(s, len);
574c798a 1077 incpush(p, TRUE, TRUE, FALSE);
0df16ed7
GS		 1078 sv_catpvn(sv, "-I", 2);
1079 sv_catpvn(sv, p, len);
1080 sv_catpvn(sv, " ", 1);
6224f72b 1081 Safefree(p);
0df16ed7
GS		 1082 }
1083 else
a67e862a 1084 Perl_croak(aTHX_ "No directory specified for -I");
6224f72b
GS		 1085 break;
1086 case 'P':
1087 forbid_setid("-P");
3280af22 1088 PL_preprocess = TRUE;
6224f72b
GS		 1089 s++;
1090 goto reswitch;
1091 case 'S':
1092 forbid_setid("-S");
1093 dosearch = TRUE;
1094 s++;
1095 goto reswitch;
1096 case 'V':
3280af22
NIS		 1097 if (!PL_preambleav)
1098 PL_preambleav = newAV();
1099 av_push(PL_preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
6224f72b 1100 if (*++s != ':') {
3280af22 1101 PL_Sv = newSVpv("print myconfig();",0);
6224f72b 1102#ifdef VMS
6b88bc9c 1103 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
6224f72b 1104#else
3280af22 1105 sv_catpv(PL_Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
6224f72b 1106#endif
3280af22 1107 sv_catpv(PL_Sv,"\" Compile-time options:");
6224f72b 1108# ifdef DEBUGGING
3280af22 1109 sv_catpv(PL_Sv," DEBUGGING");
6224f72b 1110# endif
6224f72b 1111# ifdef MULTIPLICITY
8f872242 1112 sv_catpv(PL_Sv," MULTIPLICITY");
6224f72b 1113# endif
4d1ff10f
AB		 1114# ifdef USE_5005THREADS
1115 sv_catpv(PL_Sv," USE_5005THREADS");
b363f7ed 1116# endif
ac5e8965
JH		 1117# ifdef USE_ITHREADS
1118 sv_catpv(PL_Sv," USE_ITHREADS");
1119# endif
10cc9d2a
JH		 1120# ifdef USE_64_BIT_INT
1121 sv_catpv(PL_Sv," USE_64_BIT_INT");
1122# endif
1123# ifdef USE_64_BIT_ALL
1124 sv_catpv(PL_Sv," USE_64_BIT_ALL");
ac5e8965
JH		 1125# endif
1126# ifdef USE_LONG_DOUBLE
1127 sv_catpv(PL_Sv," USE_LONG_DOUBLE");
1128# endif
53430762
JH		 1129# ifdef USE_LARGE_FILES
1130 sv_catpv(PL_Sv," USE_LARGE_FILES");
1131# endif
ac5e8965
JH		 1132# ifdef USE_SOCKS
1133 sv_catpv(PL_Sv," USE_SOCKS");
1134# endif
b363f7ed
GS		 1135# ifdef PERL_IMPLICIT_CONTEXT
1136 sv_catpv(PL_Sv," PERL_IMPLICIT_CONTEXT");
1137# endif
1138# ifdef PERL_IMPLICIT_SYS
1139 sv_catpv(PL_Sv," PERL_IMPLICIT_SYS");
1140# endif
3280af22 1141 sv_catpv(PL_Sv,"\\n\",");
b363f7ed 1142
6224f72b
GS		 1143#if defined(LOCAL_PATCH_COUNT)
1144 if (LOCAL_PATCH_COUNT > 0) {
1145 int i;
3280af22 1146 sv_catpv(PL_Sv,"\" Locally applied patches:\\n\",");
6224f72b 1147 for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
3280af22 1148 if (PL_localpatches[i])
cea2e8a9 1149 Perl_sv_catpvf(aTHX_ PL_Sv,"q\" \t%s\n\",",PL_localpatches[i]);
6224f72b
GS		 1150 }
1151 }
1152#endif
cea2e8a9 1153 Perl_sv_catpvf(aTHX_ PL_Sv,"\" Built under %s\\n\"",OSNAME);
6224f72b
GS		 1154#ifdef __DATE__
1155# ifdef __TIME__
cea2e8a9 1156 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
6224f72b 1157# else
cea2e8a9 1158 Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled on %s\\n\"",__DATE__);
6224f72b
GS		 1159# endif
1160#endif
3280af22 1161 sv_catpv(PL_Sv, "; \
6224f72b 1162$\"=\"\\n \"; \
69fcd688
JH		 1163@env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; ");
1164#ifdef __CYGWIN__
1165 sv_catpv(PL_Sv,"\
1166push @env, \"CYGWIN=\\\"$ENV{CYGWIN}\\\"\";");
1167#endif
1168 sv_catpv(PL_Sv, "\
6224f72b
GS		 1169print \" \\%ENV:\\n @env\\n\" if @env; \
1170print \" \\@INC:\\n @INC\\n\";");
1171 }
1172 else {
3280af22
NIS		 1173 PL_Sv = newSVpv("config_vars(qw(",0);
1174 sv_catpv(PL_Sv, ++s);
1175 sv_catpv(PL_Sv, "))");
6224f72b
GS		 1176 s += strlen(s);
1177 }
3280af22 1178 av_push(PL_preambleav, PL_Sv);
6224f72b
GS		 1179 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
1180 goto reswitch;
1181 case 'x':
3280af22 1182 PL_doextract = TRUE;
6224f72b
GS		 1183 s++;
1184 if (*s)
f4c556ac 1185 cddir = s;
6224f72b
GS		 1186 break;
1187 case 0:
1188 break;
1189 case '-':
1190 if (!*++s || isSPACE(*s)) {
1191 argc--,argv++;
1192 goto switch_end;
1193 }
1194 /* catch use of gnu style long options */
1195 if (strEQ(s, "version")) {
1196 s = "v";
1197 goto reswitch;
1198 }
1199 if (strEQ(s, "help")) {
1200 s = "h";
1201 goto reswitch;
1202 }
1203 s--;
1204 /* FALL THROUGH */
1205 default:
cea2e8a9 1206 Perl_croak(aTHX_ "Unrecognized switch: -%s (-h will show valid options)",s);
8d063cd8
LW		 1207 }
1208 }
6224f72b 1209 switch_end:
7f9e821f 1210 sv_setsv(get_sv("/", TRUE), PL_rs);
54310121 1211
f675dbe5
CB		 1212 if (
1213#ifndef SECURE_INTERNAL_GETENV
1214 !PL_tainting &&
1215#endif
cf756827 1216 (s = PerlEnv_getenv("PERL5OPT")))
0df16ed7 1217 {
cf756827 1218 char *popt = s;
74288ac8
GS		 1219 while (isSPACE(*s))
1220 s++;
317ea90d 1221 if (*s == '-' && *(s+1) == 'T') {
74288ac8 1222 PL_tainting = TRUE;
317ea90d
MS		 1223 PL_taint_warn = FALSE;
1224 }
74288ac8 1225 else {
cf756827 1226 char *popt_copy = Nullch;
74288ac8 1227 while (s && *s) {
4ea8f8fb 1228 char *d;
74288ac8
GS		 1229 while (isSPACE(*s))
1230 s++;
1231 if (*s == '-') {
1232 s++;
1233 if (isSPACE(*s))
1234 continue;
1235 }
4ea8f8fb 1236 d = s;
74288ac8
GS		 1237 if (!*s)
1238 break;
06492da6 1239 if (!strchr("DIMUdmtwA", *s))
cea2e8a9 1240 Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s);
4ea8f8fb
MS		 1241 while (++s && *s) {
1242 if (isSPACE(*s)) {
cf756827
GS		 1243 if (!popt_copy) {
1244 popt_copy = SvPVX(sv_2mortal(newSVpv(popt,0)));
1245 s = popt_copy + (s - popt);
1246 d = popt_copy + (d - popt);
1247 }
4ea8f8fb
MS		 1248 *s++ = '\0';
1249 break;
1250 }
1251 }
1c4db469 1252 if (*d == 't') {
317ea90d
MS		 1253 if( !PL_tainting ) {
1254 PL_taint_warn = TRUE;
1255 PL_tainting = TRUE;
1256 }
1c4db469
RGS		 1257 } else {
1258 moreswitches(d);
1259 }
6224f72b 1260 }
6224f72b
GS		 1261 }
1262 }
a0d0e21e 1263
317ea90d
MS		 1264 if (PL_taint_warn && PL_dowarn != G_WARN_ALL_OFF) {
1265 PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
1266 }
1267
6224f72b
GS		 1268 if (!scriptname)
1269 scriptname = argv[0];
3280af22 1270 if (PL_e_script) {
6224f72b
GS		 1271 argc++,argv--;
1272 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
1273 }
1274 else if (scriptname == Nullch) {
1275#ifdef MSDOS
1276 if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
1277 moreswitches("h");
1278#endif
1279 scriptname = "-";
1280 }
1281
1282 init_perllib();
1283
1284 open_script(scriptname,dosearch,sv,&fdscript);
1285
1286 validate_suid(validarg, scriptname,fdscript);
1287
64ca3a65 1288#ifndef PERL_MICRO
0b5b802d
GS		 1289#if defined(SIGCHLD) || defined(SIGCLD)
1290 {
1291#ifndef SIGCHLD
1292# define SIGCHLD SIGCLD
1293#endif
1294 Sighandler_t sigstate = rsignal_state(SIGCHLD);
1295 if (sigstate == SIG_IGN) {
1296 if (ckWARN(WARN_SIGNAL))
9014280d 1297 Perl_warner(aTHX_ packWARN(WARN_SIGNAL),
0b5b802d
GS		 1298 "Can't ignore signal CHLD, forcing to default");
1299 (void)rsignal(SIGCHLD, (Sighandler_t)SIG_DFL);
1300 }
1301 }
1302#endif
64ca3a65 1303#endif
0b5b802d 1304
bf4acbe4
GS		 1305#ifdef MACOS_TRADITIONAL
1306 if (PL_doextract || gMacPerl_AlwaysExtract) {
1307#else
f4c556ac 1308 if (PL_doextract) {
bf4acbe4 1309#endif
6224f72b 1310 find_beginning();
f4c556ac
GS		 1311 if (cddir && PerlDir_chdir(cddir) < 0)
1312 Perl_croak(aTHX_ "Can't chdir to %s",cddir);
1313
1314 }
6224f72b 1315
3280af22
NIS		 1316 PL_main_cv = PL_compcv = (CV*)NEWSV(1104,0);
1317 sv_upgrade((SV *)PL_compcv, SVt_PVCV);
1318 CvUNIQUE_on(PL_compcv);
1319
dd2155a4 1320 CvPADLIST(PL_compcv) = pad_new(0);
4d1ff10f 1321#ifdef USE_5005THREADS
533c011a
NIS		 1322 CvOWNER(PL_compcv) = 0;
1323 New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
1324 MUTEX_INIT(CvMUTEXP(PL_compcv));
4d1ff10f 1325#endif /* USE_5005THREADS */
6224f72b 1326
0c4f7ff0 1327 boot_core_PerlIO();
6224f72b 1328 boot_core_UNIVERSAL();
9a34ef1d 1329#ifndef PERL_MICRO
09bef843 1330 boot_core_xsutils();
9a34ef1d 1331#endif
6224f72b
GS		 1332
1333 if (xsinit)
acfe0abc 1334 (*xsinit)(aTHX); /* in case linked C routines want magical variables */
64ca3a65 1335#ifndef PERL_MICRO
ed79a026 1336#if defined(VMS) || defined(WIN32) || defined(DJGPP) || defined(__CYGWIN__) || defined(EPOC)
c5be433b 1337 init_os_extras();
6224f72b 1338#endif
64ca3a65 1339#endif
6224f72b 1340
29209bc5 1341#ifdef USE_SOCKS
1b9c9cf5
DH		 1342# ifdef HAS_SOCKS5_INIT
1343 socks5_init(argv[0]);
1344# else
29209bc5 1345 SOCKSinit(argv[0]);
1b9c9cf5 1346# endif
ac27b0f5 1347#endif
29209bc5 1348
6224f72b
GS		 1349 init_predump_symbols();
1350 /* init_postdump_symbols not currently designed to be called */
1351 /* more than once (ENV isn't cleared first, for example) */
1352 /* But running with -u leaves %ENV & @ARGV undefined! XXX */
3280af22 1353 if (!PL_do_undump)
6224f72b
GS		 1354 init_postdump_symbols(argc,argv,env);
1355
a05d7ebb
JH		 1356 /* PL_unicode is turned on by -C or by $ENV{PERL_UNICODE}.
1357 * PL_utf8locale is conditionally turned on by
085a54d9 1358 * locale.c:Perl_init_i18nl10n() if the environment
a05d7ebb
JH		 1359 * look like the user wants to use UTF-8. */
1360 if (PL_unicode) { /* Requires init_predump_symbols(). */
b310b053
JH		 1361 IO* io;
1362 PerlIO* fp;
1363 SV* sv;
a05d7ebb
JH		 1364
1365 if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) {
1366 /* Turn on UTF-8-ness on STDIN, STDOUT, STDERR
1367 * and the default open discipline. */
1368 if ((PL_unicode & PERL_UNICODE_STDIN_FLAG) &&
1369 PL_stdingv && (io = GvIO(PL_stdingv)) &&
1370 (fp = IoIFP(io)))
1371 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
1372 if ((PL_unicode & PERL_UNICODE_STDOUT_FLAG) &&
1373 PL_defoutgv && (io = GvIO(PL_defoutgv)) &&
1374 (fp = IoOFP(io)))
1375 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
1376 if ((PL_unicode & PERL_UNICODE_STDERR_FLAG) &&
1377 PL_stderrgv && (io = GvIO(PL_stderrgv)) &&
1378 (fp = IoOFP(io)))
1379 PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
1380 if ((PL_unicode & PERL_UNICODE_INOUT_FLAG) &&
1381 (sv = GvSV(gv_fetchpv("\017PEN", TRUE, SVt_PV)))) {
1382 U32 in = PL_unicode & PERL_UNICODE_IN_FLAG;
1383 U32 out = PL_unicode & PERL_UNICODE_OUT_FLAG;
1384 if (in) {
1385 if (out)
1386 sv_setpvn(sv, ":utf8\0:utf8", 11);
1387 else
1388 sv_setpvn(sv, ":utf8\0", 6);
1389 }
1390 else if (out)
1391 sv_setpvn(sv, "\0:utf8", 6);
1392 SvSETMAGIC(sv);
1393 }
b310b053
JH		 1394 }
1395 }
1396
6224f72b
GS		 1397 init_lexer();
1398
1399 /* now parse the script */
1400
93189314 1401 SETERRNO(0,SS_NORMAL);
3280af22 1402 PL_error_count = 0;
bf4acbe4
GS		 1403#ifdef MACOS_TRADITIONAL
1404 if (gMacPerl_SyntaxError = (yyparse() || PL_error_count)) {
1405 if (PL_minus_c)
1406 Perl_croak(aTHX_ "%s had compilation errors.\n", MacPerl_MPWFileName(PL_origfilename));
1407 else {
1408 Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
1409 MacPerl_MPWFileName(PL_origfilename));
1410 }
1411 }
1412#else
3280af22
NIS		 1413 if (yyparse() || PL_error_count) {
1414 if (PL_minus_c)
cea2e8a9 1415 Perl_croak(aTHX_ "%s had compilation errors.\n", PL_origfilename);
6224f72b 1416 else {
cea2e8a9 1417 Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
097ee67d 1418 PL_origfilename);
6224f72b
GS		 1419 }
1420 }
bf4acbe4 1421#endif
57843af0 1422 CopLINE_set(PL_curcop, 0);
3280af22
NIS		 1423 PL_curstash = PL_defstash;
1424 PL_preprocess = FALSE;
1425 if (PL_e_script) {
1426 SvREFCNT_dec(PL_e_script);
1427 PL_e_script = Nullsv;
6224f72b
GS		 1428 }
1429
3280af22 1430 if (PL_do_undump)
6224f72b
GS		 1431 my_unexec();
1432
57843af0
GS		 1433 if (isWARN_ONCE) {
1434 SAVECOPFILE(PL_curcop);
1435 SAVECOPLINE(PL_curcop);
3280af22 1436 gv_check(PL_defstash);
57843af0 1437 }
6224f72b
GS		 1438
1439 LEAVE;
1440 FREETMPS;
1441
1442#ifdef MYMALLOC
1443 if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
1444 dump_mstats("after compilation:");
1445#endif
1446
1447 ENTER;
3280af22 1448 PL_restartop = 0;
312caa8e 1449 return NULL;
6224f72b
GS		 1450}
1451
954c1994
GS		 1452/*
1453=for apidoc perl_run
1454
1455Tells a Perl interpreter to run. See L<perlembed>.
1456
1457=cut
1458*/
1459
6224f72b 1460int
0cb96387 1461perl_run(pTHXx)
6224f72b 1462{
6224f72b 1463 I32 oldscope;
14dd3ad8 1464 int ret = 0;
db36c5a1 1465 dJMPENV;
4d1ff10f 1466#ifdef USE_5005THREADS
cea2e8a9
GS		 1467 dTHX;
1468#endif
6224f72b 1469
3280af22 1470 oldscope = PL_scopestack_ix;
96e176bf
CL		 1471#ifdef VMS
1472 VMSISH_HUSHED = 0;
1473#endif
6224f72b 1474
14dd3ad8 1475#ifdef PERL_FLEXIBLE_EXCEPTIONS
312caa8e 1476 redo_body:
14dd3ad8
GS		 1477 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vrun_body), oldscope);
1478#else
1479 JMPENV_PUSH(ret);
1480#endif
6224f72b
GS		 1481 switch (ret) {
1482 case 1:
1483 cxstack_ix = -1; /* start context stack again */
312caa8e 1484 goto redo_body;
14dd3ad8
GS		 1485 case 0: /* normal completion */
1486#ifndef PERL_FLEXIBLE_EXCEPTIONS
1487 redo_body:
1488 run_body(oldscope);
1489#endif
1490 /* FALL THROUGH */
1491 case 2: /* my_exit() */
3280af22 1492 while (PL_scopestack_ix > oldscope)
6224f72b
GS		 1493 LEAVE;
1494 FREETMPS;
3280af22 1495 PL_curstash = PL_defstash;
3a1ee7e8 1496 if (!(PL_exit_flags & PERL_EXIT_DESTRUCT_END) &&
31d77e54
AB		 1497 PL_endav && !PL_minus_c)
1498 call_list(oldscope, PL_endav);
6224f72b
GS		 1499#ifdef MYMALLOC
1500 if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
1501 dump_mstats("after execution: ");
1502#endif
14dd3ad8
GS		 1503 ret = STATUS_NATIVE_EXPORT;
1504 break;
6224f72b 1505 case 3:
312caa8e
CS		 1506 if (PL_restartop) {
1507 POPSTACK_TO(PL_mainstack);
1508 goto redo_body;
6224f72b 1509 }
bf49b057 1510 PerlIO_printf(Perl_error_log, "panic: restartop\n");
312caa8e 1511 FREETMPS;
14dd3ad8
GS		 1512 ret = 1;
1513 break;
6224f72b
GS		 1514 }
1515
14dd3ad8
GS		 1516 JMPENV_POP;
1517 return ret;
312caa8e
CS		 1518}
1519
14dd3ad8 1520#ifdef PERL_FLEXIBLE_EXCEPTIONS
312caa8e 1521STATIC void *
14dd3ad8 1522S_vrun_body(pTHX_ va_list args)
312caa8e 1523{
312caa8e
CS		 1524 I32 oldscope = va_arg(args, I32);
1525
14dd3ad8
GS		 1526 return run_body(oldscope);
1527}
1528#endif
1529
1530
1531STATIC void *
1532S_run_body(pTHX_ I32 oldscope)
1533{
6224f72b 1534 DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
3280af22 1535 PL_sawampersand ? "Enabling" : "Omitting"));
6224f72b 1536
3280af22 1537 if (!PL_restartop) {
6224f72b
GS		 1538 DEBUG_x(dump_all());
1539 DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
b900a521
JH		 1540 DEBUG_S(PerlIO_printf(Perl_debug_log, "main thread is 0x%"UVxf"\n",
1541 PTR2UV(thr)));
6224f72b 1542
3280af22 1543 if (PL_minus_c) {
bf4acbe4 1544#ifdef MACOS_TRADITIONAL
e69a2255
JH		 1545 PerlIO_printf(Perl_error_log, "%s%s syntax OK\n",
1546 (gMacPerl_ErrorFormat ? "# " : ""),
1547 MacPerl_MPWFileName(PL_origfilename));
bf4acbe4 1548#else
bf49b057 1549 PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename);
bf4acbe4 1550#endif
6224f72b
GS		 1551 my_exit(0);
1552 }
3280af22 1553 if (PERLDB_SINGLE && PL_DBsingle)
ac27b0f5 1554 sv_setiv(PL_DBsingle, 1);
3280af22
NIS		 1555 if (PL_initav)
1556 call_list(oldscope, PL_initav);
6224f72b
GS		 1557 }
1558
1559 /* do it */
1560
3280af22 1561 if (PL_restartop) {
533c011a 1562 PL_op = PL_restartop;
3280af22 1563 PL_restartop = 0;
cea2e8a9 1564 CALLRUNOPS(aTHX);
6224f72b 1565 }
3280af22
NIS		 1566 else if (PL_main_start) {
1567 CvDEPTH(PL_main_cv) = 1;
533c011a 1568 PL_op = PL_main_start;
cea2e8a9 1569 CALLRUNOPS(aTHX);
6224f72b
GS		 1570 }
1571
f6b3007c
JH		 1572 my_exit(0);
1573 /* NOTREACHED */
312caa8e 1574 return NULL;
6224f72b
GS		 1575}
1576
954c1994 1577/*
ccfc67b7
JH		 1578=head1 SV Manipulation Functions
1579
954c1994
GS		 1580=for apidoc p||get_sv
1581
1582Returns the SV of the specified Perl scalar. If C<create> is set and the
1583Perl variable does not exist then it will be created. If C<create> is not
1584set and the variable does not exist then NULL is returned.
1585
1586=cut
1587*/
1588
6224f72b 1589SV*
864dbfa3 1590Perl_get_sv(pTHX_ const char *name, I32 create)
6224f72b
GS		 1591{
1592 GV *gv;
4d1ff10f 1593#ifdef USE_5005THREADS
6224f72b
GS		 1594 if (name[1] == '\0' && !isALPHA(name[0])) {
1595 PADOFFSET tmp = find_threadsv(name);
411caa50 1596 if (tmp != NOT_IN_PAD)
6224f72b 1597 return THREADSV(tmp);
6224f72b 1598 }
4d1ff10f 1599#endif /* USE_5005THREADS */
6224f72b
GS		 1600 gv = gv_fetchpv(name, create, SVt_PV);
1601 if (gv)
1602 return GvSV(gv);
1603 return Nullsv;
1604}
1605
954c1994 1606/*
ccfc67b7
JH		 1607=head1 Array Manipulation Functions
1608
954c1994
GS		 1609=for apidoc p||get_av
1610
1611Returns the AV of the specified Perl array. If C<create> is set and the
1612Perl variable does not exist then it will be created. If C<create> is not
1613set and the variable does not exist then NULL is returned.
1614
1615=cut
1616*/
1617
6224f72b 1618AV*
864dbfa3 1619Perl_get_av(pTHX_ const char *name, I32 create)
6224f72b
GS		 1620{
1621 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
1622 if (create)
1623 return GvAVn(gv);
1624 if (gv)
1625 return GvAV(gv);
1626 return Nullav;
1627}
1628
954c1994 1629/*
ccfc67b7
JH		 1630=head1 Hash Manipulation Functions
1631
954c1994
GS		 1632=for apidoc p||get_hv
1633
1634Returns the HV of the specified Perl hash. If C<create> is set and the
1635Perl variable does not exist then it will be created. If C<create> is not
1636set and the variable does not exist then NULL is returned.
1637
1638=cut
1639*/
1640
6224f72b 1641HV*
864dbfa3 1642Perl_get_hv(pTHX_ const char *name, I32 create)
6224f72b 1643{
a0d0e21e
LW		 1644 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
1645 if (create)
1646 return GvHVn(gv);
1647 if (gv)
1648 return GvHV(gv);
1649 return Nullhv;
1650}
1651
954c1994 1652/*
ccfc67b7
JH		 1653=head1 CV Manipulation Functions
1654
954c1994
GS		 1655=for apidoc p||get_cv
1656
1657Returns the CV of the specified Perl subroutine. If C<create> is set and
1658the Perl subroutine does not exist then it will be declared (which has the
1659same effect as saying C<sub name;>). If C<create> is not set and the
1660subroutine does not exist then NULL is returned.
1661
1662=cut
1663*/
1664
a0d0e21e 1665CV*
864dbfa3 1666Perl_get_cv(pTHX_ const char *name, I32 create)
a0d0e21e
LW		 1667{
1668 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
b099ddc0 1669 /* XXX unsafe for threads if eval_owner isn't held */
f6ec51f7
GS		 1670 /* XXX this is probably not what they think they're getting.
1671 * It has the same effect as "sub name;", i.e. just a forward
1672 * declaration! */
8ebc5c01 1673 if (create && !GvCVu(gv))
774d564b 1674 return newSUB(start_subparse(FALSE, 0),
a0d0e21e 1675 newSVOP(OP_CONST, 0, newSVpv(name,0)),
4633a7c4 1676 Nullop,
a0d0e21e
LW		 1677 Nullop);
1678 if (gv)
8ebc5c01 1679 return GvCVu(gv);
a0d0e21e
LW		 1680 return Nullcv;
1681}
1682
79072805
LW		 1683/* Be sure to refetch the stack pointer after calling these routines. */
1684
954c1994 1685/*
ccfc67b7
JH		 1686
1687=head1 Callback Functions
1688
954c1994
GS		 1689=for apidoc p||call_argv
1690
1691Performs a callback to the specified Perl sub. See L<perlcall>.
1692
1693=cut
1694*/
1695
a0d0e21e 1696I32
864dbfa3 1697Perl_call_argv(pTHX_ const char *sub_name, I32 flags, register char **argv)
ac27b0f5 1698
8ac85365
NIS		 1699 /* See G_* flags in cop.h */
1700 /* null terminated arg list */
8990e307 1701{
a0d0e21e 1702 dSP;
8990e307 1703
924508f0 1704 PUSHMARK(SP);
a0d0e21e 1705 if (argv) {
8990e307 1706 while (*argv) {
a0d0e21e 1707 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
8990e307
LW		 1708 argv++;
1709 }
a0d0e21e 1710 PUTBACK;
8990e307 1711 }
864dbfa3 1712 return call_pv(sub_name, flags);
8990e307
LW		 1713}
1714
954c1994
GS		 1715/*
1716=for apidoc p||call_pv
1717
1718Performs a callback to the specified Perl sub. See L<perlcall>.
1719
1720=cut
1721*/
1722
a0d0e21e 1723I32
864dbfa3 1724Perl_call_pv(pTHX_ const char *sub_name, I32 flags)
8ac85365
NIS		 1725 /* name of the subroutine */
1726 /* See G_* flags in cop.h */
a0d0e21e 1727{
864dbfa3 1728 return call_sv((SV*)get_cv(sub_name, TRUE), flags);
a0d0e21e
LW		 1729}
1730
954c1994
GS		 1731/*
1732=for apidoc p||call_method
1733
1734Performs a callback to the specified Perl method. The blessed object must
1735be on the stack. See L<perlcall>.
1736
1737=cut
1738*/
1739
a0d0e21e 1740I32
864dbfa3 1741Perl_call_method(pTHX_ const char *methname, I32 flags)
8ac85365
NIS		 1742 /* name of the subroutine */
1743 /* See G_* flags in cop.h */
a0d0e21e 1744{
968b3946 1745 return call_sv(sv_2mortal(newSVpv(methname,0)), flags | G_METHOD);
a0d0e21e
LW		 1746}
1747
1748/* May be called with any of a CV, a GV, or an SV containing the name. */
954c1994
GS		 1749/*
1750=for apidoc p||call_sv
1751
1752Performs a callback to the Perl sub whose name is in the SV. See
1753L<perlcall>.
1754
1755=cut
1756*/
1757
a0d0e21e 1758I32
864dbfa3 1759Perl_call_sv(pTHX_ SV *sv, I32 flags)
8ac85365 1760 /* See G_* flags in cop.h */
a0d0e21e 1761{
924508f0 1762 dSP;
a0d0e21e 1763 LOGOP myop; /* fake syntax tree node */
968b3946 1764 UNOP method_op;
aa689395 1765 I32 oldmark;
13689cfe 1766 volatile I32 retval = 0;
a0d0e21e 1767 I32 oldscope;
54310121 1768 bool oldcatch = CATCH_GET;
6224f72b 1769 int ret;
533c011a 1770 OP* oldop = PL_op;
db36c5a1 1771 dJMPENV;
1e422769 1772
a0d0e21e
LW		 1773 if (flags & G_DISCARD) {
1774 ENTER;
1775 SAVETMPS;
1776 }
1777
aa689395 1778 Zero(&myop, 1, LOGOP);
54310121 1779 myop.op_next = Nullop;
f51d4af5 1780 if (!(flags & G_NOARGS))
aa689395 1781 myop.op_flags |= OPf_STACKED;
54310121 1782 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1783 (flags & G_ARRAY) ? OPf_WANT_LIST :
1784 OPf_WANT_SCALAR);
462e5cf6 1785 SAVEOP();
533c011a 1786 PL_op = (OP*)&myop;
aa689395 1787
3280af22
NIS		 1788 EXTEND(PL_stack_sp, 1);
1789 *++PL_stack_sp = sv;
aa689395 1790 oldmark = TOPMARK;
3280af22 1791 oldscope = PL_scopestack_ix;
a0d0e21e 1792
3280af22 1793 if (PERLDB_SUB && PL_curstash != PL_debstash
36477c24 1794 /* Handle first BEGIN of -d. */
3280af22 1795 && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub)))
36477c24 1796 /* Try harder, since this may have been a sighandler, thus
1797 * curstash may be meaningless. */
3280af22 1798 && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != PL_debstash)
491527d0 1799 && !(flags & G_NODEBUG))
533c011a 1800 PL_op->op_private |= OPpENTERSUB_DB;
a0d0e21e 1801
968b3946
GS		 1802 if (flags & G_METHOD) {
1803 Zero(&method_op, 1, UNOP);
1804 method_op.op_next = PL_op;
1805 method_op.op_ppaddr = PL_ppaddr[OP_METHOD];
1806 myop.op_ppaddr = PL_ppaddr[OP_ENTERSUB];
f39d0b86 1807 PL_op = (OP*)&method_op;
968b3946
GS		 1808 }
1809
312caa8e 1810 if (!(flags & G_EVAL)) {
0cdb2077 1811 CATCH_SET(TRUE);
14dd3ad8 1812 call_body((OP*)&myop, FALSE);
312caa8e 1813 retval = PL_stack_sp - (PL_stack_base + oldmark);
0253cb41 1814 CATCH_SET(oldcatch);
312caa8e
CS		 1815 }
1816 else {
d78bda3d 1817 myop.op_other = (OP*)&myop;
3280af22 1818 PL_markstack_ptr--;
4633a7c4
LW		 1819 /* we're trying to emulate pp_entertry() here */
1820 {
c09156bb 1821 register PERL_CONTEXT *cx;
54310121 1822 I32 gimme = GIMME_V;
ac27b0f5 1823
4633a7c4
LW		 1824 ENTER;
1825 SAVETMPS;
ac27b0f5 1826
968b3946 1827 push_return(Nullop);
1d76a5c3 1828 PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
4633a7c4 1829 PUSHEVAL(cx, 0, 0);
533c011a 1830 PL_eval_root = PL_op; /* Only needed so that goto works right. */
ac27b0f5 1831
faef0170 1832 PL_in_eval = EVAL_INEVAL;
4633a7c4 1833 if (flags & G_KEEPERR)
faef0170 1834 PL_in_eval |= EVAL_KEEPERR;
4633a7c4 1835 else
38a03e6e 1836 sv_setpv(ERRSV,"");
4633a7c4 1837 }
3280af22 1838 PL_markstack_ptr++;
a0d0e21e 1839
14dd3ad8
GS		 1840#ifdef PERL_FLEXIBLE_EXCEPTIONS
1841 redo_body:
1842 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_body),
db36c5a1 1843 (OP*)&myop, FALSE);
14dd3ad8
GS		 1844#else
1845 JMPENV_PUSH(ret);
1846#endif
6224f72b
GS		 1847 switch (ret) {
1848 case 0:
14dd3ad8
GS		 1849#ifndef PERL_FLEXIBLE_EXCEPTIONS
1850 redo_body:
1851 call_body((OP*)&myop, FALSE);
1852#endif
312caa8e
CS		 1853 retval = PL_stack_sp - (PL_stack_base + oldmark);
1854 if (!(flags & G_KEEPERR))
1855 sv_setpv(ERRSV,"");
a0d0e21e 1856 break;
6224f72b 1857 case 1:
f86702cc 1858 STATUS_ALL_FAILURE;
a0d0e21e 1859 /* FALL THROUGH */
6224f72b 1860 case 2:
a0d0e21e 1861 /* my_exit() was called */
3280af22 1862 PL_curstash = PL_defstash;
a0d0e21e 1863 FREETMPS;
14dd3ad8 1864 JMPENV_POP;
cc3604b1 1865 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
cea2e8a9 1866 Perl_croak(aTHX_ "Callback called exit");
f86702cc 1867 my_exit_jump();
a0d0e21e 1868 /* NOTREACHED */
6224f72b 1869 case 3:
3280af22 1870 if (PL_restartop) {
533c011a 1871 PL_op = PL_restartop;
3280af22 1872 PL_restartop = 0;
312caa8e 1873 goto redo_body;
a0d0e21e 1874 }
3280af22 1875 PL_stack_sp = PL_stack_base + oldmark;
a0d0e21e
LW		 1876 if (flags & G_ARRAY)
1877 retval = 0;
1878 else {
1879 retval = 1;
3280af22 1880 *++PL_stack_sp = &PL_sv_undef;
a0d0e21e 1881 }
312caa8e 1882 break;
a0d0e21e 1883 }
a0d0e21e 1884
3280af22 1885 if (PL_scopestack_ix > oldscope) {
a0a2876f
LW		 1886 SV **newsp;
1887 PMOP *newpm;
1888 I32 gimme;
c09156bb 1889 register PERL_CONTEXT *cx;
a0a2876f
LW		 1890 I32 optype;
1891
1892 POPBLOCK(cx,newpm);
1893 POPEVAL(cx);
1894 pop_return();
3280af22 1895 PL_curpm = newpm;
a0a2876f 1896 LEAVE;
a0d0e21e 1897 }
14dd3ad8 1898 JMPENV_POP;
a0d0e21e 1899 }
1e422769 1900
a0d0e21e 1901 if (flags & G_DISCARD) {
3280af22 1902 PL_stack_sp = PL_stack_base + oldmark;
a0d0e21e
LW		 1903 retval = 0;
1904 FREETMPS;
1905 LEAVE;
1906 }
533c011a 1907 PL_op = oldop;
a0d0e21e
LW		 1908 return retval;
1909}
1910
14dd3ad8 1911#ifdef PERL_FLEXIBLE_EXCEPTIONS
312caa8e 1912STATIC void *
14dd3ad8 1913S_vcall_body(pTHX_ va_list args)
312caa8e
CS		 1914{
1915 OP *myop = va_arg(args, OP*);
1916 int is_eval = va_arg(args, int);
1917
14dd3ad8 1918 call_body(myop, is_eval);
312caa8e
CS		 1919 return NULL;
1920}
14dd3ad8 1921#endif
312caa8e
CS		 1922
1923STATIC void
14dd3ad8 1924S_call_body(pTHX_ OP *myop, int is_eval)
312caa8e 1925{
312caa8e
CS		 1926 if (PL_op == myop) {
1927 if (is_eval)
f807eda9 1928 PL_op = Perl_pp_entereval(aTHX); /* this doesn't do a POPMARK */
312caa8e 1929 else
f807eda9 1930 PL_op = Perl_pp_entersub(aTHX); /* this does */
312caa8e
CS		 1931 }
1932 if (PL_op)
cea2e8a9 1933 CALLRUNOPS(aTHX);
312caa8e
CS		 1934}
1935
6e72f9df 1936/* Eval a string. The G_EVAL flag is always assumed. */
8990e307 1937
954c1994
GS		 1938/*
1939=for apidoc p||eval_sv
1940
1941Tells Perl to C<eval> the string in the SV.
1942
1943=cut
1944*/
1945
a0d0e21e 1946I32
864dbfa3 1947Perl_eval_sv(pTHX_ SV *sv, I32 flags)
ac27b0f5 1948
8ac85365 1949 /* See G_* flags in cop.h */
a0d0e21e 1950{
924508f0 1951 dSP;
a0d0e21e 1952 UNOP myop; /* fake syntax tree node */
8fa7f367 1953 volatile I32 oldmark = SP - PL_stack_base;
13689cfe 1954 volatile I32 retval = 0;
4633a7c4 1955 I32 oldscope;
6224f72b 1956 int ret;
533c011a 1957 OP* oldop = PL_op;
db36c5a1 1958 dJMPENV;
84902520 1959
4633a7c4
LW		 1960 if (flags & G_DISCARD) {
1961 ENTER;
1962 SAVETMPS;
1963 }
1964
462e5cf6 1965 SAVEOP();
533c011a
NIS		 1966 PL_op = (OP*)&myop;
1967 Zero(PL_op, 1, UNOP);
3280af22
NIS		 1968 EXTEND(PL_stack_sp, 1);
1969 *++PL_stack_sp = sv;
1970 oldscope = PL_scopestack_ix;
79072805 1971
4633a7c4
LW		 1972 if (!(flags & G_NOARGS))
1973 myop.op_flags = OPf_STACKED;
79072805 1974 myop.op_next = Nullop;
6e72f9df 1975 myop.op_type = OP_ENTEREVAL;
54310121 1976 myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID :
1977 (flags & G_ARRAY) ? OPf_WANT_LIST :
1978 OPf_WANT_SCALAR);
6e72f9df 1979 if (flags & G_KEEPERR)
1980 myop.op_flags |= OPf_SPECIAL;
4633a7c4 1981
14dd3ad8 1982#ifdef PERL_FLEXIBLE_EXCEPTIONS
312caa8e 1983 redo_body:
14dd3ad8 1984 CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_body),
db36c5a1 1985 (OP*)&myop, TRUE);
14dd3ad8
GS		 1986#else
1987 JMPENV_PUSH(ret);
1988#endif
6224f72b
GS		 1989 switch (ret) {
1990 case 0:
14dd3ad8
GS		 1991#ifndef PERL_FLEXIBLE_EXCEPTIONS
1992 redo_body:
1993 call_body((OP*)&myop,TRUE);
1994#endif
312caa8e
CS		 1995 retval = PL_stack_sp - (PL_stack_base + oldmark);
1996 if (!(flags & G_KEEPERR))
1997 sv_setpv(ERRSV,"");
4633a7c4 1998 break;
6224f72b 1999 case 1:
f86702cc 2000 STATUS_ALL_FAILURE;
4633a7c4 2001 /* FALL THROUGH */
6224f72b 2002 case 2:
4633a7c4 2003 /* my_exit() was called */
3280af22 2004 PL_curstash = PL_defstash;
4633a7c4 2005 FREETMPS;
14dd3ad8 2006 JMPENV_POP;
cc3604b1 2007 if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED))
cea2e8a9 2008 Perl_croak(aTHX_ "Callback called exit");
f86702cc 2009 my_exit_jump();
4633a7c4 2010 /* NOTREACHED */
6224f72b 2011 case 3:
3280af22 2012 if (PL_restartop) {
533c011a 2013 PL_op = PL_restartop;
3280af22 2014 PL_restartop = 0;
312caa8e 2015 goto redo_body;
4633a7c4 2016 }
3280af22 2017 PL_stack_sp = PL_stack_base + oldmark;
4633a7c4
LW		 2018 if (flags & G_ARRAY)
2019 retval = 0;
2020 else {
2021 retval = 1;
3280af22 2022 *++PL_stack_sp = &PL_sv_undef;
4633a7c4 2023 }
312caa8e 2024 break;
4633a7c4
LW		 2025 }
2026
14dd3ad8 2027 JMPENV_POP;
4633a7c4 2028 if (flags & G_DISCARD) {
3280af22 2029 PL_stack_sp = PL_stack_base + oldmark;
4633a7c4
LW		 2030 retval = 0;
2031 FREETMPS;
2032 LEAVE;
2033 }
533c011a 2034 PL_op = oldop;
4633a7c4
LW		 2035 return retval;
2036}
2037
954c1994
GS		 2038/*
2039=for apidoc p||eval_pv
2040
2041Tells Perl to C<eval> the given string and return an SV* result.
2042
2043=cut
2044*/
2045
137443ea 2046SV*
864dbfa3 2047Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
137443ea 2048{
2049 dSP;
2050 SV* sv = newSVpv(p, 0);
2051
864dbfa3 2052 eval_sv(sv, G_SCALAR);
137443ea 2053 SvREFCNT_dec(sv);
2054
2055 SPAGAIN;
2056 sv = POPs;
2057 PUTBACK;
2058
2d8e6c8d
GS		 2059 if (croak_on_error && SvTRUE(ERRSV)) {
2060 STRLEN n_a;
cea2e8a9 2061 Perl_croak(aTHX_ SvPVx(ERRSV, n_a));
2d8e6c8d 2062 }
137443ea 2063
2064 return sv;
2065}
2066
4633a7c4
LW		 2067/* Require a module. */
2068
954c1994 2069/*
ccfc67b7
JH		 2070=head1 Embedding Functions
2071
954c1994
GS		 2072=for apidoc p||require_pv
2073
7d3fb230
BS		 2074Tells Perl to C<require> the file named by the string argument. It is
2075analogous to the Perl code C<eval "require '$file'">. It's even
2076implemented that way; consider using Perl_load_module instead.
954c1994 2077
7d3fb230 2078=cut */
954c1994 2079
4633a7c4 2080void
864dbfa3 2081Perl_require_pv(pTHX_ const char *pv)
4633a7c4 2082{
d3acc0f7
JP		 2083 SV* sv;
2084 dSP;
e788e7d3 2085 PUSHSTACKi(PERLSI_REQUIRE);
d3acc0f7
JP		 2086 PUTBACK;
2087 sv = sv_newmortal();
4633a7c4
LW		 2088 sv_setpv(sv, "require '");
2089 sv_catpv(sv, pv);
2090 sv_catpv(sv, "'");
864dbfa3 2091 eval_sv(sv, G_DISCARD);
d3acc0f7
JP		 2092 SPAGAIN;
2093 POPSTACK;
79072805
LW		 2094}
2095
79072805 2096void
864dbfa3 2097Perl_magicname(pTHX_ char *sym, char *name, I32 namlen)
79072805
LW		 2098{
2099 register GV *gv;
2100
155aba94 2101 if ((gv = gv_fetchpv(sym,TRUE, SVt_PV)))
14befaf4 2102 sv_magic(GvSV(gv), (SV*)gv, PERL_MAGIC_sv, name, namlen);
79072805
LW		 2103}
2104
76e3520e 2105STATIC void
cea2e8a9 2106S_usage(pTHX_ char *name) /* XXX move this out into a module ? */
4633a7c4 2107{
ab821d7f 2108 /* This message really ought to be max 23 lines.
75c72d73 2109 * Removed -h because the user already knows that option. Others? */
fb73857a 2110
76e3520e 2111 static char *usage_msg[] = {
fb73857a 2112"-0[octal] specify record separator (\\0, if no argument)",
2113"-a autosplit mode with -n or -p (splits $_ into @F)",
46487f74 2114"-C enable native wide character system interfaces",
1950ee41 2115"-c check syntax only (runs BEGIN and CHECK blocks)",
aac3bd0d
GS		 2116"-d[:debugger] run program under debugger",
2117"-D[number/list] set debugging flags (argument is a bit mask or alphabets)",
2118"-e 'command' one line of program (several -e's allowed, omit programfile)",
2119"-F/pattern/ split() pattern for -a switch (//'s are optional)",
2120"-i[extension] edit <> files in place (makes backup if extension supplied)",
2121"-Idirectory specify @INC/#include directory (several -I's allowed)",
fb73857a 2122"-l[octal] enable line ending processing, specifies line terminator",
aac3bd0d
GS		 2123"-[mM][-]module execute `use/no module...' before executing program",
2124"-n assume 'while (<>) { ... }' loop around program",
2125"-p assume loop like -n but print line also, like sed",
2126"-P run program through C preprocessor before compilation",
2127"-s enable rudimentary parsing for switches after programfile",
2128"-S look for programfile using PATH environment variable",
2129"-T enable tainting checks",
9cbc33e8 2130"-t enable tainting warnings",
aac3bd0d 2131"-u dump core after parsing program",
fb73857a 2132"-U allow unsafe operations",
aac3bd0d
GS		 2133"-v print version, subversion (includes VERY IMPORTANT perl info)",
2134"-V[:variable] print configuration summary (or a single Config.pm variable)",
2135"-w enable many useful warnings (RECOMMENDED)",
3c0facb2
GS		 2136"-W enable all warnings",
2137"-X disable all warnings",
fb73857a 2138"-x[directory] strip off text before #!perl line and perhaps cd to directory",
2139"\n",
2140NULL
2141};
76e3520e 2142 char **p = usage_msg;
fb73857a 2143
b0e47665
GS		 2144 PerlIO_printf(PerlIO_stdout(),
2145 "\nUsage: %s [switches] [--] [programfile] [arguments]",
2146 name);
fb73857a 2147 while (*p)
b0e47665 2148 PerlIO_printf(PerlIO_stdout(), "\n %s", *p++);
4633a7c4
LW		 2149}
2150
79072805
LW		 2151/* This routine handles any switches that can be given during run */
2152
2153char *
864dbfa3 2154Perl_moreswitches(pTHX_ char *s)
79072805 2155{
ba210ebe 2156 STRLEN numlen;
c07a80fd 2157 U32 rschar;
79072805
LW		 2158
2159 switch (*s) {
2160 case '0':
a863c7d1 2161 {
53305cf1
NC		 2162 I32 flags = 0;
2163 numlen = 4;
2164 rschar = (U32)grok_oct(s, &numlen, &flags, NULL);
8bfdd7d9 2165 SvREFCNT_dec(PL_rs);
c07a80fd 2166 if (rschar & ~((U8)~0))
8bfdd7d9 2167 PL_rs = &PL_sv_undef;
c07a80fd 2168 else if (!rschar && numlen >= 2)
8bfdd7d9 2169 PL_rs = newSVpvn("", 0);
c07a80fd 2170 else {
eb160463 2171 char ch = (char)rschar;
8bfdd7d9 2172 PL_rs = newSVpvn(&ch, 1);
79072805
LW		 2173 }
2174 return s + numlen;
a863c7d1 2175 }
46487f74 2176 case 'C':
a05d7ebb
JH		 2177 s++;
2178 PL_unicode = parse_unicode_opts(&s);
46487f74 2179 return s;
2304df62 2180 case 'F':
3280af22 2181 PL_minus_F = TRUE;
ebce5377
RGS		 2182 PL_splitstr = ++s;
2183 while (*s && !isSPACE(*s)) ++s;
2184 *s = '\0';
2185 PL_splitstr = savepv(PL_splitstr);
2304df62 2186 return s;
79072805 2187 case 'a':
3280af22 2188 PL_minus_a = TRUE;
79072805
LW		 2189 s++;
2190 return s;
2191 case 'c':
3280af22 2192 PL_minus_c = TRUE;
79072805
LW		 2193 s++;
2194 return s;
2195 case 'd':
bbce6d69 2196 forbid_setid("-d");
4633a7c4 2197 s++;
70c94a19
RR		 2198 /* The following permits -d:Mod to accepts arguments following an =
2199 in the fashion that -MSome::Mod does. */
2200 if (*s == ':' || *s == '=') {
2201 char *start;
2202 SV *sv;
2203 sv = newSVpv("use Devel::", 0);
2204 start = ++s;
2205 /* We now allow -d:Module=Foo,Bar */
2206 while(isALNUM(*s) || *s==':') ++s;
2207 if (*s != '=')
2208 sv_catpv(sv, start);
2209 else {
2210 sv_catpvn(sv, start, s-start);
2211 sv_catpv(sv, " split(/,/,q{");
2212 sv_catpv(sv, ++s);
2213 sv_catpv(sv, "})");
2214 }
4633a7c4 2215 s += strlen(s);
70c94a19 2216 my_setenv("PERL5DB", SvPV(sv, PL_na));
4633a7c4 2217 }
ed094faf 2218 if (!PL_perldb) {
3280af22 2219 PL_perldb = PERLDB_ALL;
a0d0e21e 2220 init_debugger();
ed094faf 2221 }
79072805
LW		 2222 return s;
2223 case 'D':
0453d815 2224 {
79072805 2225#ifdef DEBUGGING
bbce6d69 2226 forbid_setid("-D");
79072805 2227 if (isALPHA(s[1])) {
04932ac8 2228 /* if adding extra options, remember to update DEBUG_MASK */
7bab3ede 2229 static char debopts[] = "psltocPmfrxu HXDSTRJvC";
79072805
LW		 2230 char *d;
2231
93a17b20 2232 for (s++; *s && (d = strchr(debopts,*s)); s++)
3280af22 2233 PL_debug |= 1 << (d - debopts);
79072805
LW		 2234 }
2235 else {
3280af22 2236 PL_debug = atoi(s+1);
79072805
LW		 2237 for (s++; isDIGIT(*s); s++) ;
2238 }
2ac72d6e 2239#ifdef EBCDIC
12a43e32
JH		 2240 if (DEBUG_p_TEST_ && ckWARN_d(WARN_DEBUGGING))
2241 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
2242 "-Dp not implemented on this platform\n");
2243#endif
aea4f609 2244 PL_debug |= DEBUG_TOP_FLAG;
12a43e32 2245#else /* !DEBUGGING */
0453d815 2246 if (ckWARN_d(WARN_DEBUGGING))
9014280d 2247 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
0453d815 2248 "Recompile perl with -DDEBUGGING to use -D switch\n");
a0d0e21e 2249 for (s++; isALNUM(*s); s++) ;
79072805
LW		 2250#endif
2251 /*SUPPRESS 530*/
2252 return s;
0453d815 2253 }
4633a7c4 2254 case 'h':
ac27b0f5 2255 usage(PL_origargv[0]);
7ca617d0 2256 my_exit(0);
79072805 2257 case 'i':
3280af22
NIS		 2258 if (PL_inplace)
2259 Safefree(PL_inplace);
c030f24b
GH		 2260#if defined(__CYGWIN__) /* do backup extension automagically */
2261 if (*(s+1) == '\0') {
2262 PL_inplace = savepv(".bak");
2263 return s+1;
2264 }
2265#endif /* __CYGWIN__ */
3280af22 2266 PL_inplace = savepv(s+1);
79072805 2267 /*SUPPRESS 530*/
3280af22 2268 for (s = PL_inplace; *s && !isSPACE(*s); s++) ;
7b8d334a 2269 if (*s) {
fb73857a 2270 *s++ = '\0';
7b8d334a
GS		 2271 if (*s == '-') /* Additional switches on #! line. */
2272 s++;
2273 }
fb73857a 2274 return s;
4e49a025 2275 case 'I': /* -I handled both here and in parse_body() */
bbce6d69 2276 forbid_setid("-I");
fb73857a 2277 ++s;
2278 while (*s && isSPACE(*s))
2279 ++s;
2280 if (*s) {
774d564b 2281 char *e, *p;
0df16ed7
GS		 2282 p = s;
2283 /* ignore trailing spaces (possibly followed by other switches) */
2284 do {
2285 for (e = p; *e && !isSPACE(*e); e++) ;
2286 p = e;
2287 while (isSPACE(*p))
2288 p++;
2289 } while (*p && *p != '-');
2290 e = savepvn(s, e-s);
574c798a 2291 incpush(e, TRUE, TRUE, FALSE);
0df16ed7
GS		 2292 Safefree(e);
2293 s = p;
2294 if (*s == '-')
2295 s++;
79072805
LW		 2296 }
2297 else
a67e862a 2298 Perl_croak(aTHX_ "No directory specified for -I");
fb73857a 2299 return s;
79072805 2300 case 'l':
3280af22 2301 PL_minus_l = TRUE;
79072805 2302 s++;
7889fe52
NIS		 2303 if (PL_ors_sv) {
2304 SvREFCNT_dec(PL_ors_sv);
2305 PL_ors_sv = Nullsv;
2306 }
79072805 2307 if (isDIGIT(*s)) {
53305cf1 2308 I32 flags = 0;
7889fe52 2309 PL_ors_sv = newSVpvn("\n",1);
53305cf1
NC		 2310 numlen = 3 + (*s == '0');
2311 *SvPVX(PL_ors_sv) = (char)grok_oct(s, &numlen, &flags, NULL);
79072805
LW		 2312 s += numlen;
2313 }
2314 else {
8bfdd7d9 2315 if (RsPARA(PL_rs)) {
7889fe52
NIS		 2316 PL_ors_sv = newSVpvn("\n\n",2);
2317 }
2318 else {
8bfdd7d9 2319 PL_ors_sv = newSVsv(PL_rs);
c07a80fd 2320 }
79072805
LW		 2321 }
2322 return s;
06492da6
SF		 2323 case 'A':
2324 forbid_setid("-A");
2325 if (*++s) {
2326 SV *sv=newSVpv("use assertions::activate split(/,/,q{",0);
2327 sv_catpv(sv,s);
2328 sv_catpv(sv,"})");
2329 s+=strlen(s);
2330 if(!PL_preambleav)
2331 PL_preambleav = newAV();
2332 av_push(PL_preambleav, sv);
2333 }
2334 else
2335 Perl_croak(aTHX_ "No space allowed after -A");
2336 return s;
1a30305b 2337 case 'M':
bbce6d69 2338 forbid_setid("-M"); /* XXX ? */
1a30305b 2339 /* FALL THROUGH */
2340 case 'm':
bbce6d69 2341 forbid_setid("-m"); /* XXX ? */
1a30305b 2342 if (*++s) {
a5f75d66 2343 char *start;
11343788 2344 SV *sv;
a5f75d66
AD		 2345 char *use = "use ";
2346 /* -M-foo == 'no foo' */
2347 if (*s == '-') { use = "no "; ++s; }
11343788 2348 sv = newSVpv(use,0);
a5f75d66 2349 start = s;
1a30305b 2350 /* We allow -M'Module qw(Foo Bar)' */
c07a80fd 2351 while(isALNUM(*s) || *s==':') ++s;
2352 if (*s != '=') {
11343788 2353 sv_catpv(sv, start);
c07a80fd 2354 if (*(start-1) == 'm') {
2355 if (*s != '\0')
cea2e8a9 2356 Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
11343788 2357 sv_catpv( sv, " ()");
c07a80fd 2358 }
2359 } else {
6df41af2 2360 if (s == start)
be98fb35
GS		 2361 Perl_croak(aTHX_ "Module name required with -%c option",
2362 s[-1]);
11343788
MB		 2363 sv_catpvn(sv, start, s-start);
2364 sv_catpv(sv, " split(/,/,q{");
2365 sv_catpv(sv, ++s);
2366 sv_catpv(sv, "})");
c07a80fd 2367 }
1a30305b 2368 s += strlen(s);
5c831c24 2369 if (!PL_preambleav)
3280af22
NIS		 2370 PL_preambleav = newAV();
2371 av_push(PL_preambleav, sv);
1a30305b 2372 }
2373 else
cea2e8a9 2374 Perl_croak(aTHX_ "No space allowed after -%c", *(s-1));
1a30305b 2375 return s;
79072805 2376 case 'n':
3280af22 2377 PL_minus_n = TRUE;
79072805
LW		 2378 s++;
2379 return s;
2380 case 'p':
3280af22 2381 PL_minus_p = TRUE;
79072805
LW		 2382 s++;
2383 return s;
2384 case 's':
bbce6d69 2385 forbid_setid("-s");
3280af22 2386 PL_doswitches = TRUE;
79072805
LW		 2387 s++;
2388 return s;
6537fe72
MS		 2389 case 't':
2390 if (!PL_tainting)
2391 Perl_croak(aTHX_ "Too late for \"-t\" option");
2392 s++;
2393 return s;
463ee0b2 2394 case 'T':
3280af22 2395 if (!PL_tainting)
cea2e8a9 2396 Perl_croak(aTHX_ "Too late for \"-T\" option");
463ee0b2
LW		 2397 s++;
2398 return s;
79072805 2399 case 'u':
bf4acbe4
GS		 2400#ifdef MACOS_TRADITIONAL
2401 Perl_croak(aTHX_ "Believe me, you don't want to use \"-u\" on a Macintosh");
2402#endif
3280af22 2403 PL_do_undump = TRUE;
79072805
LW		 2404 s++;
2405 return s;
2406 case 'U':
3280af22 2407 PL_unsafe = TRUE;
79072805
LW		 2408 s++;
2409 return s;
2410 case 'v':
8e9464f1 2411#if !defined(DGUX)
b0e47665 2412 PerlIO_printf(PerlIO_stdout(),
d2560b70 2413 Perl_form(aTHX_ "\nThis is perl, v%"VDf" built for %s",
b0e47665 2414 PL_patchlevel, ARCHNAME));
8e9464f1
JH		 2415#else /* DGUX */
2416/* Adjust verbose output as in the perl that ships with the DG/UX OS from EMC */
2417 PerlIO_printf(PerlIO_stdout(),
2418 Perl_form(aTHX_ "\nThis is perl, version %vd\n", PL_patchlevel));
2419 PerlIO_printf(PerlIO_stdout(),
2420 Perl_form(aTHX_ " built under %s at %s %s\n",
2421 OSNAME, __DATE__, __TIME__));
2422 PerlIO_printf(PerlIO_stdout(),
2423 Perl_form(aTHX_ " OS Specific Release: %s\n",
40a39f85 2424 OSVERS));
8e9464f1
JH		 2425#endif /* !DGUX */
2426
fb73857a 2427#if defined(LOCAL_PATCH_COUNT)
2428 if (LOCAL_PATCH_COUNT > 0)
b0e47665
GS		 2429 PerlIO_printf(PerlIO_stdout(),
2430 "\n(with %d registered patch%s, "
2431 "see perl -V for more detail)",
2432 (int)LOCAL_PATCH_COUNT,
2433 (LOCAL_PATCH_COUNT!=1) ? "es" : "");
a5f75d66 2434#endif
1a30305b 2435
b0e47665 2436 PerlIO_printf(PerlIO_stdout(),
be3c0a43 2437 "\n\nCopyright 1987-2002, Larry Wall\n");
eae9c151
JH		 2438#ifdef MACOS_TRADITIONAL
2439 PerlIO_printf(PerlIO_stdout(),
be3c0a43 2440 "\nMac OS port Copyright 1991-2002, Matthias Neeracher;\n"
03765510 2441 "maintained by Chris Nandor\n");
eae9c151 2442#endif
79072805 2443#ifdef MSDOS
b0e47665
GS		 2444 PerlIO_printf(PerlIO_stdout(),
2445 "\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
55497cff 2446#endif
2447#ifdef DJGPP
b0e47665
GS		 2448 PerlIO_printf(PerlIO_stdout(),
2449 "djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n"
2450 "djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
4633a7c4 2451#endif
79072805 2452#ifdef OS2
b0e47665
GS		 2453 PerlIO_printf(PerlIO_stdout(),
2454 "\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
be3c0a43 2455 "Version 5 port Copyright (c) 1994-2002, Andreas Kaiser, Ilya Zakharevich\n");
79072805 2456#endif
79072805 2457#ifdef atarist
b0e47665
GS		 2458 PerlIO_printf(PerlIO_stdout(),
2459 "atariST series port, ++jrb bammi@cadence.com\n");
79072805 2460#endif
a3f9223b 2461#ifdef __BEOS__
b0e47665
GS		 2462 PerlIO_printf(PerlIO_stdout(),
2463 "BeOS port Copyright Tom Spindler, 1997-1999\n");
a3f9223b 2464#endif
1d84e8df 2465#ifdef MPE
b0e47665 2466 PerlIO_printf(PerlIO_stdout(),
be3c0a43 2467 "MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-2002\n");
1d84e8df 2468#endif
9d116dd7 2469#ifdef OEMVS
b0e47665
GS		 2470 PerlIO_printf(PerlIO_stdout(),
2471 "MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
9d116dd7 2472#endif
495c5fdc 2473#ifdef __VOS__
b0e47665 2474 PerlIO_printf(PerlIO_stdout(),
94efb9fb 2475 "Stratus VOS port by Paul.Green@stratus.com, 1997-2002\n");
495c5fdc 2476#endif
092bebab 2477#ifdef __OPEN_VM
b0e47665
GS		 2478 PerlIO_printf(PerlIO_stdout(),
2479 "VM/ESA port by Neale Ferguson, 1998-1999\n");
092bebab 2480#endif
a1a0e61e 2481#ifdef POSIX_BC
b0e47665
GS		 2482 PerlIO_printf(PerlIO_stdout(),
2483 "BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
a1a0e61e 2484#endif
61ae2fbf 2485#ifdef __MINT__
b0e47665
GS		 2486 PerlIO_printf(PerlIO_stdout(),
2487 "MiNT port by Guido Flohr, 1997-1999\n");
61ae2fbf 2488#endif
f83d2536 2489#ifdef EPOC
b0e47665 2490 PerlIO_printf(PerlIO_stdout(),
be3c0a43 2491 "EPOC port by Olaf Flebbe, 1999-2002\n");
f83d2536 2492#endif
e1caacb4 2493#ifdef UNDER_CE
be3c0a43 2494 printf("WINCE port by Rainer Keuchel, 2001-2002\n");
e1caacb4
JH		 2495 printf("Built on " __DATE__ " " __TIME__ "\n\n");
2496 wce_hitreturn();
2497#endif
baed7233
DL		 2498#ifdef BINARY_BUILD_NOTICE
2499 BINARY_BUILD_NOTICE;
2500#endif
b0e47665
GS		 2501 PerlIO_printf(PerlIO_stdout(),
2502 "\n\
79072805 2503Perl may be copied only under the terms of either the Artistic License or the\n\
3d6f292d 2504GNU General Public License, which may be found in the Perl 5 source kit.\n\n\
95103687
GS		 2505Complete documentation for Perl, including FAQ lists, should be found on\n\
2506this system using `man perl' or `perldoc perl'. If you have access to the\n\
2507Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n");
7ca617d0 2508 my_exit(0);
79072805 2509 case 'w':
599cee73 2510 if (! (PL_dowarn & G_WARN_ALL_MASK))
ac27b0f5 2511 PL_dowarn |= G_WARN_ON;
599cee73
PM		 2512 s++;
2513 return s;
2514 case 'W':
ac27b0f5 2515 PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
317ea90d
MS		 2516 if (!specialWARN(PL_compiling.cop_warnings))
2517 SvREFCNT_dec(PL_compiling.cop_warnings);
d3a7d8c7 2518 PL_compiling.cop_warnings = pWARN_ALL ;
599cee73
PM		 2519 s++;
2520 return s;
2521 case 'X':
ac27b0f5 2522 PL_dowarn = G_WARN_ALL_OFF;
317ea90d
MS		 2523 if (!specialWARN(PL_compiling.cop_warnings))
2524 SvREFCNT_dec(PL_compiling.cop_warnings);
d3a7d8c7 2525 PL_compiling.cop_warnings = pWARN_NONE ;
79072805
LW		 2526 s++;
2527 return s;
a0d0e21e 2528 case '*':
79072805
LW		 2529 case ' ':
2530 if (s[1] == '-') /* Additional switches on #! line. */
2531 return s+2;
2532 break;
a0d0e21e 2533 case '-':
79072805 2534 case 0:
51882d45 2535#if defined(WIN32) || !defined(PERL_STRICT_CR)
a868473f
NIS		 2536 case '\r':
2537#endif
79072805
LW		 2538 case '\n':
2539 case '\t':
2540 break;
aa689395 2541#ifdef ALTERNATE_SHEBANG
2542 case 'S': /* OS/2 needs -S on "extproc" line. */
2543 break;
2544#endif
a0d0e21e 2545 case 'P':
3280af22 2546 if (PL_preprocess)
a0d0e21e
LW		 2547 return s+1;
2548 /* FALL THROUGH */
79072805 2549 default:
cea2e8a9 2550 Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
79072805
LW		 2551 }
2552 return Nullch;
2553}
2554
2555/* compliments of Tom Christiansen */
2556
2557/* unexec() can be found in the Gnu emacs distribution */
ee580363 2558/* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
79072805
LW		 2559
2560void
864dbfa3 2561Perl_my_unexec(pTHX)
79072805
LW		 2562{
2563#ifdef UNEXEC
46fc3d4c 2564 SV* prog;
2565 SV* file;
ee580363 2566 int status = 1;
79072805
LW		 2567 extern int etext;
2568
ee580363 2569 prog = newSVpv(BIN_EXP, 0);
46fc3d4c 2570 sv_catpv(prog, "/perl");
6b88bc9c 2571 file = newSVpv(PL_origfilename, 0);
46fc3d4c 2572 sv_catpv(file, ".perldump");
79072805 2573
ee580363
GS		 2574 unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
2575 /* unexec prints msg to stderr in case of failure */
6ad3d225 2576 PerlProc_exit(status);
79072805 2577#else
a5f75d66
AD		 2578# ifdef VMS
2579# include <lib$routines.h>
2580 lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
aa689395 2581# else
79072805 2582 ABORT(); /* for use with undump */
aa689395 2583# endif
a5f75d66 2584#endif
79072805
LW		 2585}
2586
cb68f92d
GS		 2587/* initialize curinterp */
2588STATIC void
cea2e8a9 2589S_init_interp(pTHX)
cb68f92d
GS		 2590{
2591
acfe0abc
GS		 2592#ifdef MULTIPLICITY
2593# define PERLVAR(var,type)
2594# define PERLVARA(var,n,type)
2595# if defined(PERL_IMPLICIT_CONTEXT)
2596# if defined(USE_5005THREADS)
2597# define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
c5be433b 2598# define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
acfe0abc
GS		 2599# else /* !USE_5005THREADS */
2600# define PERLVARI(var,type,init) aTHX->var = init;
2601# define PERLVARIC(var,type,init) aTHX->var = init;
2602# endif /* USE_5005THREADS */
3967c732 2603# else
acfe0abc
GS		 2604# define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
2605# define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
066ef5b5 2606# endif
acfe0abc
GS		 2607# include "intrpvar.h"
2608# ifndef USE_5005THREADS
2609# include "thrdvar.h"
2610# endif
2611# undef PERLVAR
2612# undef PERLVARA
2613# undef PERLVARI
2614# undef PERLVARIC
2615#else
2616# define PERLVAR(var,type)
2617# define PERLVARA(var,n,type)
2618# define PERLVARI(var,type,init) PL_##var = init;
2619# define PERLVARIC(var,type,init) PL_##var = init;
2620# include "intrpvar.h"
2621# ifndef USE_5005THREADS
2622# include "thrdvar.h"
2623# endif
2624# undef PERLVAR
2625# undef PERLVARA
2626# undef PERLVARI
2627# undef PERLVARIC
cb68f92d
GS		 2628#endif
2629
cb68f92d
GS		 2630}
2631
76e3520e 2632STATIC void
cea2e8a9 2633S_init_main_stash(pTHX)
79072805 2634{
463ee0b2 2635 GV *gv;
6e72f9df 2636
3280af22 2637 PL_curstash = PL_defstash = newHV();
79cb57f6 2638 PL_curstname = newSVpvn("main",4);
adbc6bb1
LW		 2639 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
2640 SvREFCNT_dec(GvHV(gv));
3280af22 2641 GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);
463ee0b2 2642 SvREADONLY_on(gv);
3280af22
NIS		 2643 HvNAME(PL_defstash) = savepv("main");
2644 PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
2645 GvMULTI_on(PL_incgv);
2646 PL_hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */
2647 GvMULTI_on(PL_hintgv);
2648 PL_defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
2649 PL_errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
2650 GvMULTI_on(PL_errgv);
2651 PL_replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */
2652 GvMULTI_on(PL_replgv);
cea2e8a9 2653 (void)Perl_form(aTHX_ "%240s",""); /* Preallocate temp - for immediate signals. */
38a03e6e
MB		 2654 sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
2655 sv_setpvn(ERRSV, "", 0);
3280af22 2656 PL_curstash = PL_defstash;
11faa288 2657 CopSTASH_set(&PL_compiling, PL_defstash);
ed094faf 2658 PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
3280af22 2659 PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
4633a7c4 2660 /* We must init $/ before switches are processed. */
864dbfa3 2661 sv_setpvn(get_sv("/", TRUE), "\n", 1);
79072805
LW		 2662}
2663
76e3520e 2664STATIC void
cea2e8a9 2665S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript)
79072805 2666{
1b24ed4b
MS		 2667 char *quote;
2668 char *code;
2669 char *cpp_discard_flag;
2670 char *perl;
2671
6c4ab083 2672 *fdscript = -1;
79072805 2673
3280af22
NIS		 2674 if (PL_e_script) {
2675 PL_origfilename = savepv("-e");
96436eeb 2676 }
6c4ab083
GS		 2677 else {
2678 /* if find_script() returns, it returns a malloc()-ed value */
3280af22 2679 PL_origfilename = scriptname = find_script(scriptname, dosearch, NULL, 1);
6c4ab083
GS		 2680
2681 if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
2682 char *s = scriptname + 8;
2683 *fdscript = atoi(s);
2684 while (isDIGIT(*s))
2685 s++;
2686 if (*s) {
2687 scriptname = savepv(s + 1);
3280af22
NIS		 2688 Safefree(PL_origfilename);
2689 PL_origfilename = scriptname;
6c4ab083
GS		 2690 }
2691 }
2692 }
2693
05ec9bb3 2694 CopFILE_free(PL_curcop);
57843af0 2695 CopFILE_set(PL_curcop, PL_origfilename);
3280af22 2696 if (strEQ(PL_origfilename,"-"))
79072805 2697 scriptname = "";
01f988be 2698 if (*fdscript >= 0) {
3280af22 2699 PL_rsfp = PerlIO_fdopen(*fdscript,PERL_SCRIPT_MODE);
1b24ed4b
MS		 2700# if defined(HAS_FCNTL) && defined(F_SETFD)
2701 if (PL_rsfp)
2702 /* ensure close-on-exec */
2703 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);
2704# endif
96436eeb 2705 }
3280af22 2706 else if (PL_preprocess) {
46fc3d4c 2707 char *cpp_cfg = CPPSTDIN;
79cb57f6 2708 SV *cpp = newSVpvn("",0);
46fc3d4c 2709 SV *cmd = NEWSV(0,0);
2710
2711 if (strEQ(cpp_cfg, "cppstdin"))
cea2e8a9 2712 Perl_sv_catpvf(aTHX_ cpp, "%s/", BIN_EXP);
46fc3d4c 2713 sv_catpv(cpp, cpp_cfg);
79072805 2714
1b24ed4b
MS		 2715# ifndef VMS
2716 sv_catpvn(sv, "-I", 2);
2717 sv_catpv(sv,PRIVLIB_EXP);
2718# endif
46fc3d4c 2719
14953ddc
MB		 2720 DEBUG_P(PerlIO_printf(Perl_debug_log,
2721 "PL_preprocess: scriptname=\"%s\", cpp=\"%s\", sv=\"%s\", CPPMINUS=\"%s\"\n",
2722 scriptname, SvPVX (cpp), SvPVX (sv), CPPMINUS));
1b24ed4b
MS		 2723
2724# if defined(MSDOS) || defined(WIN32) || defined(VMS)
2725 quote = "\"";
2726# else
2727 quote = "'";
2728# endif
2729
2730# ifdef VMS
2731 cpp_discard_flag = "";
2732# else
2733 cpp_discard_flag = "-C";
2734# endif
2735
2736# ifdef OS2
2737 perl = os2_execname(aTHX);
2738# else
2739 perl = PL_origargv[0];
2740# endif
2741
2742
2743 /* This strips off Perl comments which might interfere with
62375a60
NIS		 2744 the C pre-processor, including #!. #line directives are
2745 deliberately stripped to avoid confusion with Perl's version
1b24ed4b
MS		 2746 of #line. FWP played some golf with it so it will fit
2747 into VMS's 255 character buffer.
2748 */
2749 if( PL_doextract )
2750 code = "(1../^#!.*perl/i)|/^\\s*#(?!\\s*((ifn?|un)def|(el|end)?if|define|include|else|error|pragma)\\b)/||!($|=1)||print";
2751 else
2752 code = "/^\\s*#(?!\\s*((ifn?|un)def|(el|end)?if|define|include|else|error|pragma)\\b)/||!($|=1)||print";
2753
2754 Perl_sv_setpvf(aTHX_ cmd, "\
2755%s -ne%s%s%s %s | %"SVf" %s %"SVf" %s",
62375a60 2756 perl, quote, code, quote, scriptname, cpp,
1b24ed4b
MS		 2757 cpp_discard_flag, sv, CPPMINUS);
2758
3280af22 2759 PL_doextract = FALSE;
1b24ed4b
MS		 2760# ifdef IAMSUID /* actually, this is caught earlier */
2761 if (PL_euid != PL_uid && !PL_euid) { /* if running suidperl */
2762# ifdef HAS_SETEUID
2763 (void)seteuid(PL_uid); /* musn't stay setuid root */
2764# else
2765# ifdef HAS_SETREUID
2766 (void)setreuid((Uid_t)-1, PL_uid);
2767# else
2768# ifdef HAS_SETRESUID
2769 (void)setresuid((Uid_t)-1, PL_uid, (Uid_t)-1);
2770# else
2771 PerlProc_setuid(PL_uid);
2772# endif
2773# endif
2774# endif
b28d0864 2775 if (PerlProc_geteuid() != PL_uid)
cea2e8a9 2776 Perl_croak(aTHX_ "Can't do seteuid!\n");
79072805 2777 }
1b24ed4b 2778# endif /* IAMSUID */
0a6c758d 2779
62375a60
NIS		 2780 DEBUG_P(PerlIO_printf(Perl_debug_log,
2781 "PL_preprocess: cmd=\"%s\"\n",
0a6c758d
MS		 2782 SvPVX(cmd)));
2783
3280af22 2784 PL_rsfp = PerlProc_popen(SvPVX(cmd), "r");
46fc3d4c 2785 SvREFCNT_dec(cmd);
2786 SvREFCNT_dec(cpp);
79072805
LW		 2787 }
2788 else if (!*scriptname) {
bbce6d69 2789 forbid_setid("program input from stdin");
3280af22 2790 PL_rsfp = PerlIO_stdin();
79072805 2791 }
96436eeb 2792 else {
3280af22 2793 PL_rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
1b24ed4b
MS		 2794# if defined(HAS_FCNTL) && defined(F_SETFD)
2795 if (PL_rsfp)
2796 /* ensure close-on-exec */
2797 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);
2798# endif
96436eeb 2799 }
3280af22 2800 if (!PL_rsfp) {
1b24ed4b
MS		 2801# ifdef DOSUID
2802# ifndef IAMSUID /* in case script is not readable before setuid */
2803 if (PL_euid &&
2804 PerlLIO_stat(CopFILE(PL_curcop),&PL_statbuf) >= 0 &&
2805 PL_statbuf.st_mode & (S_ISUID|S_ISGID))
2806 {
2807 /* try again */
62375a60
NIS		 2808 PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT,
2809 BIN_EXP, (int)PERL_REVISION,
1b24ed4b
MS		 2810 (int)PERL_VERSION,
2811 (int)PERL_SUBVERSION), PL_origargv);
2812 Perl_croak(aTHX_ "Can't do setuid\n");
2813 }
2814# endif
2815# endif
2816# ifdef IAMSUID
2817 errno = EPERM;
2818 Perl_croak(aTHX_ "Can't open perl script: %s\n",
2819 Strerror(errno));
2820# else
2821 Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
2822 CopFILE(PL_curcop), Strerror(errno));
2823# endif
13281fa4 2824 }
79072805 2825}
8d063cd8 2826
7b89560d
JH		 2827/* Mention
2828 * I_SYSSTATVFS HAS_FSTATVFS
2829 * I_SYSMOUNT
c890dc6c 2830 * I_STATFS HAS_FSTATFS HAS_GETFSSTAT
7b89560d
JH		 2831 * I_MNTENT HAS_GETMNTENT HAS_HASMNTOPT
2832 * here so that metaconfig picks them up. */
2833
104d25b7 2834#ifdef IAMSUID
864dbfa3 2835STATIC int
e688b231 2836S_fd_on_nosuid_fs(pTHX_ int fd)
104d25b7 2837{
0545a864
JH		 2838 int check_okay = 0; /* able to do all the required sys/libcalls */
2839 int on_nosuid = 0; /* the fd is on a nosuid fs */
104d25b7 2840/*
ad27e871 2841 * Preferred order: fstatvfs(), fstatfs(), ustat()+getmnt(), getmntent().
e688b231 2842 * fstatvfs() is UNIX98.
0545a864 2843 * fstatfs() is 4.3 BSD.
ad27e871 2844 * ustat()+getmnt() is pre-4.3 BSD.
0545a864
JH		 2845 * getmntent() is O(number-of-mounted-filesystems) and can hang on
2846 * an irrelevant filesystem while trying to reach the right one.
104d25b7
JH		 2847 */
2848
6439433f
JH		 2849#undef FD_ON_NOSUID_CHECK_OKAY /* found the syscalls to do the check? */
2850
2851# if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
2852 defined(HAS_FSTATVFS)
2853# define FD_ON_NOSUID_CHECK_OKAY
104d25b7 2854 struct statvfs stfs;
6439433f 2855
104d25b7
JH		 2856 check_okay = fstatvfs(fd, &stfs) == 0;
2857 on_nosuid = check_okay && (stfs.f_flag & ST_NOSUID);
6439433f 2858# endif /* fstatvfs */
ac27b0f5 2859
6439433f
JH		 2860# if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
2861 defined(PERL_MOUNT_NOSUID) && \
2862 defined(HAS_FSTATFS) && \
2863 defined(HAS_STRUCT_STATFS) && \
2864 defined(HAS_STRUCT_STATFS_F_FLAGS)
2865# define FD_ON_NOSUID_CHECK_OKAY
e688b231 2866 struct statfs stfs;
6439433f 2867
104d25b7 2868 check_okay = fstatfs(fd, &stfs) == 0;
104d25b7 2869 on_nosuid = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID);
6439433f
JH		 2870# endif /* fstatfs */
2871
2872# if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
2873 defined(PERL_MOUNT_NOSUID) && \
2874 defined(HAS_FSTAT) && \
2875 defined(HAS_USTAT) && \
2876 defined(HAS_GETMNT) && \
2877 defined(HAS_STRUCT_FS_DATA) && \
2878 defined(NOSTAT_ONE)
2879# define FD_ON_NOSUID_CHECK_OKAY
c623ac67 2880 Stat_t fdst;
6439433f 2881
0545a864 2882 if (fstat(fd, &fdst) == 0) {
6439433f
JH		 2883 struct ustat us;
2884 if (ustat(fdst.st_dev, &us) == 0) {
2885 struct fs_data fsd;
2886 /* NOSTAT_ONE here because we're not examining fields which
2887 * vary between that case and STAT_ONE. */
ad27e871 2888 if (getmnt((int*)0, &fsd, (int)0, NOSTAT_ONE, us.f_fname) == 0) {
6439433f
JH		 2889 size_t cmplen = sizeof(us.f_fname);
2890 if (sizeof(fsd.fd_req.path) < cmplen)
2891 cmplen = sizeof(fsd.fd_req.path);
2892 if (strnEQ(fsd.fd_req.path, us.f_fname, cmplen) &&
2893 fdst.st_dev == fsd.fd_req.dev) {
2894 check_okay = 1;
2895 on_nosuid = fsd.fd_req.flags & PERL_MOUNT_NOSUID;
2896 }
2897 }
2898 }
2899 }
0545a864 2900 }
6439433f
JH		 2901# endif /* fstat+ustat+getmnt */
2902
2903# if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
2904 defined(HAS_GETMNTENT) && \
2905 defined(HAS_HASMNTOPT) && \
2906 defined(MNTOPT_NOSUID)
2907# define FD_ON_NOSUID_CHECK_OKAY
2908 FILE *mtab = fopen("/etc/mtab", "r");
2909 struct mntent *entry;
c623ac67 2910 Stat_t stb, fsb;
104d25b7
JH		 2911
2912 if (mtab && (fstat(fd, &stb) == 0)) {
6439433f
JH		 2913 while (entry = getmntent(mtab)) {
2914 if (stat(entry->mnt_dir, &fsb) == 0
2915 && fsb.st_dev == stb.st_dev)
2916 {
2917 /* found the filesystem */
2918 check_okay = 1;
2919 if (hasmntopt(entry, MNTOPT_NOSUID))
2920 on_nosuid = 1;
2921 break;
2922 } /* A single fs may well fail its stat(). */
2923 }
104d25b7
JH		 2924 }
2925 if (mtab)
6439433f
JH		 2926 fclose(mtab);
2927# endif /* getmntent+hasmntopt */
0545a864 2928
ac27b0f5 2929 if (!check_okay)
0545a864 2930 Perl_croak(aTHX_ "Can't check filesystem of script \"%s\" for nosuid", PL_origfilename);
104d25b7
JH		 2931 return on_nosuid;
2932}
2933#endif /* IAMSUID */
2934
76e3520e 2935STATIC void
cea2e8a9 2936S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript)
79072805 2937{
155aba94 2938#ifdef IAMSUID
96436eeb 2939 int which;
155aba94 2940#endif
96436eeb 2941
13281fa4
LW		 2942 /* do we need to emulate setuid on scripts? */
2943
2944 /* This code is for those BSD systems that have setuid #! scripts disabled
2945 * in the kernel because of a security problem. Merely defining DOSUID
2946 * in perl will not fix that problem, but if you have disabled setuid
2947 * scripts in the kernel, this will attempt to emulate setuid and setgid
2948 * on scripts that have those now-otherwise-useless bits set. The setuid
27e2fb84
LW		 2949 * root version must be called suidperl or sperlN.NNN. If regular perl
2950 * discovers that it has opened a setuid script, it calls suidperl with
2951 * the same argv that it had. If suidperl finds that the script it has
2952 * just opened is NOT setuid root, it sets the effective uid back to the
2953 * uid. We don't just make perl setuid root because that loses the
2954 * effective uid we had before invoking perl, if it was different from the
2955 * uid.
13281fa4
LW		 2956 *
2957 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
2958 * be defined in suidperl only. suidperl must be setuid root. The
2959 * Configure script will set this up for you if you want it.
2960 */
a687059c 2961
13281fa4 2962#ifdef DOSUID
6e72f9df 2963 char *s, *s2;
a0d0e21e 2964
b28d0864 2965 if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0) /* normal stat is insecure */
cea2e8a9 2966 Perl_croak(aTHX_ "Can't stat script \"%s\"",PL_origfilename);
b28d0864 2967 if (fdscript < 0 && PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
79072805 2968 I32 len;
2d8e6c8d 2969 STRLEN n_a;
13281fa4 2970
a687059c 2971#ifdef IAMSUID
fe14fcc3 2972#ifndef HAS_SETREUID
a687059c
LW		 2973 /* On this access check to make sure the directories are readable,
2974 * there is actually a small window that the user could use to make
2975 * filename point to an accessible directory. So there is a faint
2976 * chance that someone could execute a setuid script down in a
2977 * non-accessible directory. I don't know what to do about that.
2978 * But I don't think it's too important. The manual lies when
2979 * it says access() is useful in setuid programs.
2980 */
cc49e20b 2981 if (PerlLIO_access(CopFILE(PL_curcop),1)) /*double check*/
cea2e8a9 2982 Perl_croak(aTHX_ "Permission denied");
a687059c
LW		 2983#else
2984 /* If we can swap euid and uid, then we can determine access rights
2985 * with a simple stat of the file, and then compare device and
2986 * inode to make sure we did stat() on the same file we opened.
2987 * Then we just have to make sure he or she can execute it.
2988 */
2989 {
c623ac67 2990 Stat_t tmpstatbuf;
a687059c 2991
85e6fe83
LW		 2992 if (
2993#ifdef HAS_SETREUID
b28d0864 2994 setreuid(PL_euid,PL_uid) < 0
a0d0e21e
LW		 2995#else
2996# if HAS_SETRESUID
b28d0864 2997 setresuid(PL_euid,PL_uid,(Uid_t)-1) < 0
a0d0e21e 2998# endif
85e6fe83 2999#endif
b28d0864 3000 || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
cea2e8a9 3001 Perl_croak(aTHX_ "Can't swap uid and euid"); /* really paranoid */
cc49e20b 3002 if (PerlLIO_stat(CopFILE(PL_curcop),&tmpstatbuf) < 0)
cea2e8a9 3003 Perl_croak(aTHX_ "Permission denied"); /* testing full pathname here */
2bb3463c 3004#if defined(IAMSUID) && !defined(NO_NOSUID_CHECK)
e688b231 3005 if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp)))
cea2e8a9 3006 Perl_croak(aTHX_ "Permission denied");
104d25b7 3007#endif
b28d0864
NIS		 3008 if (tmpstatbuf.st_dev != PL_statbuf.st_dev ||
3009 tmpstatbuf.st_ino != PL_statbuf.st_ino) {
3010 (void)PerlIO_close(PL_rsfp);
cea2e8a9 3011 Perl_croak(aTHX_ "Permission denied\n");
a687059c 3012 }
85e6fe83
LW		 3013 if (
3014#ifdef HAS_SETREUID
b28d0864 3015 setreuid(PL_uid,PL_euid) < 0
a0d0e21e
LW		 3016#else
3017# if defined(HAS_SETRESUID)
b28d0864 3018 setresuid(PL_uid,PL_euid,(Uid_t)-1) < 0
a0d0e21e 3019# endif
85e6fe83 3020#endif
b28d0864 3021 || PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid)
cea2e8a9 3022 Perl_croak(aTHX_ "Can't reswap uid and euid");
b28d0864 3023 if (!cando(S_IXUSR,FALSE,&PL_statbuf)) /* can real uid exec? */
cea2e8a9 3024 Perl_croak(aTHX_ "Permission denied\n");
a687059c 3025 }
fe14fcc3 3026#endif /* HAS_SETREUID */
a687059c
LW		 3027#endif /* IAMSUID */
3028
b28d0864 3029 if (!S_ISREG(PL_statbuf.st_mode))
cea2e8a9 3030 Perl_croak(aTHX_ "Permission denied");
b28d0864 3031 if (PL_statbuf.st_mode & S_IWOTH)
cea2e8a9 3032 Perl_croak(aTHX_ "Setuid/gid script is writable by world");
6b88bc9c 3033 PL_doswitches = FALSE; /* -s is insecure in suid */
57843af0 3034 CopLINE_inc(PL_curcop);
6b88bc9c 3035 if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch ||
2d8e6c8d 3036 strnNE(SvPV(PL_linestr,n_a),"#!",2) ) /* required even on Sys V */
cea2e8a9 3037 Perl_croak(aTHX_ "No #! line");
2d8e6c8d 3038 s = SvPV(PL_linestr,n_a)+2;
663a0e37 3039 if (*s == ' ') s++;
45d8adaa 3040 while (!isSPACE(*s)) s++;
2d8e6c8d 3041 for (s2 = s; (s2 > SvPV(PL_linestr,n_a)+2 &&
6e72f9df 3042 (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
3043 if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
cea2e8a9 3044 Perl_croak(aTHX_ "Not a perl script");
a687059c 3045 while (*s == ' ' || *s == '\t') s++;
13281fa4
LW		 3046 /*
3047 * #! arg must be what we saw above. They can invoke it by
3048 * mentioning suidperl explicitly, but they may not add any strange
3049 * arguments beyond what #! says if they do invoke suidperl that way.
3050 */
3051 len = strlen(validarg);
3052 if (strEQ(validarg," PHOOEY ") ||
45d8adaa 3053 strnNE(s,validarg,len) || !isSPACE(s[len]))
cea2e8a9 3054 Perl_croak(aTHX_ "Args must match #! line");
a687059c
LW		 3055
3056#ifndef IAMSUID
b28d0864
NIS		 3057 if (PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
3058 PL_euid == PL_statbuf.st_uid)
3059 if (!PL_do_undump)
cea2e8a9 3060 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
a687059c
LW		 3061FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
3062#endif /* IAMSUID */
13281fa4 3063
b28d0864
NIS		 3064 if (PL_euid) { /* oops, we're not the setuid root perl */
3065 (void)PerlIO_close(PL_rsfp);
13281fa4 3066#ifndef IAMSUID
46fc3d4c 3067 /* try again */
a7cb1f99 3068 PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, BIN_EXP,
273cf8d1
GS		 3069 (int)PERL_REVISION, (int)PERL_VERSION,
3070 (int)PERL_SUBVERSION), PL_origargv);
13281fa4 3071#endif
cea2e8a9 3072 Perl_croak(aTHX_ "Can't do setuid\n");
13281fa4
LW		 3073 }
3074
b28d0864 3075 if (PL_statbuf.st_mode & S_ISGID && PL_statbuf.st_gid != PL_egid) {
fe14fcc3 3076#ifdef HAS_SETEGID
b28d0864 3077 (void)setegid(PL_statbuf.st_gid);
a687059c 3078#else
fe14fcc3 3079#ifdef HAS_SETREGID
b28d0864 3080 (void)setregid((Gid_t)-1,PL_statbuf.st_gid);
85e6fe83
LW		 3081#else
3082#ifdef HAS_SETRESGID
b28d0864 3083 (void)setresgid((Gid_t)-1,PL_statbuf.st_gid,(Gid_t)-1);
a687059c 3084#else
b28d0864 3085 PerlProc_setgid(PL_statbuf.st_gid);
a687059c
LW		 3086#endif
3087#endif
85e6fe83 3088#endif
b28d0864 3089 if (PerlProc_getegid() != PL_statbuf.st_gid)
cea2e8a9 3090 Perl_croak(aTHX_ "Can't do setegid!\n");
83025b21 3091 }
b28d0864
NIS		 3092 if (PL_statbuf.st_mode & S_ISUID) {
3093 if (PL_statbuf.st_uid != PL_euid)
fe14fcc3 3094#ifdef HAS_SETEUID
b28d0864 3095 (void)seteuid(PL_statbuf.st_uid); /* all that for this */
a687059c 3096#else
fe14fcc3 3097#ifdef HAS_SETREUID
b28d0864 3098 (void)setreuid((Uid_t)-1,PL_statbuf.st_uid);
85e6fe83
LW		 3099#else
3100#ifdef HAS_SETRESUID
b28d0864 3101 (void)setresuid((Uid_t)-1,PL_statbuf.st_uid,(Uid_t)-1);
a687059c 3102#else
b28d0864 3103 PerlProc_setuid(PL_statbuf.st_uid);
a687059c
LW		 3104#endif
3105#endif
85e6fe83 3106#endif
b28d0864 3107 if (PerlProc_geteuid() != PL_statbuf.st_uid)
cea2e8a9 3108 Perl_croak(aTHX_ "Can't do seteuid!\n");
a687059c 3109 }
b28d0864 3110 else if (PL_uid) { /* oops, mustn't run as root */
fe14fcc3 3111#ifdef HAS_SETEUID
b28d0864 3112 (void)seteuid((Uid_t)PL_uid);
a687059c 3113#else
fe14fcc3 3114#ifdef HAS_SETREUID
b28d0864 3115 (void)setreuid((Uid_t)-1,(Uid_t)PL_uid);
a687059c 3116#else
85e6fe83 3117#ifdef HAS_SETRESUID
b28d0864 3118 (void)setresuid((Uid_t)-1,(Uid_t)PL_uid,(Uid_t)-1);
85e6fe83 3119#else
b28d0864 3120 PerlProc_setuid((Uid_t)PL_uid);
85e6fe83 3121#endif
a687059c
LW		 3122#endif
3123#endif
b28d0864 3124 if (PerlProc_geteuid() != PL_uid)
cea2e8a9 3125 Perl_croak(aTHX_ "Can't do seteuid!\n");
83025b21 3126 }
748a9306 3127 init_ids();
b28d0864 3128 if (!cando(S_IXUSR,TRUE,&PL_statbuf))
cea2e8a9 3129 Perl_croak(aTHX_ "Permission denied\n"); /* they can't do this */
13281fa4
LW		 3130 }
3131#ifdef IAMSUID
6b88bc9c 3132 else if (PL_preprocess)
cea2e8a9 3133 Perl_croak(aTHX_ "-P not allowed for setuid/setgid script\n");
96436eeb 3134 else if (fdscript >= 0)
cea2e8a9 3135 Perl_croak(aTHX_ "fd script not allowed in suidperl\n");
13281fa4 3136 else
cea2e8a9 3137 Perl_croak(aTHX_ "Script is not setuid/setgid in suidperl\n");
96436eeb 3138
3139 /* We absolutely must clear out any saved ids here, so we */
3140 /* exec the real perl, substituting fd script for scriptname. */
3141 /* (We pass script name as "subdir" of fd, which perl will grok.) */
b28d0864
NIS		 3142 PerlIO_rewind(PL_rsfp);
3143 PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0); /* just in case rewind didn't */
6b88bc9c
GS		 3144 for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;
3145 if (!PL_origargv[which])
cea2e8a9
GS		 3146 Perl_croak(aTHX_ "Permission denied");
3147 PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s",
6b88bc9c 3148 PerlIO_fileno(PL_rsfp), PL_origargv[which]));
96436eeb 3149#if defined(HAS_FCNTL) && defined(F_SETFD)
b28d0864 3150 fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0); /* ensure no close-on-exec */
96436eeb 3151#endif
a7cb1f99 3152 PerlProc_execv(Perl_form(aTHX_ "%s/perl"PERL_FS_VER_FMT, BIN_EXP,
273cf8d1
GS		 3153 (int)PERL_REVISION, (int)PERL_VERSION,
3154 (int)PERL_SUBVERSION), PL_origargv);/* try again */
cea2e8a9 3155 Perl_croak(aTHX_ "Can't do setuid\n");
13281fa4 3156#endif /* IAMSUID */
a687059c 3157#else /* !DOSUID */
3280af22 3158 if (PL_euid != PL_uid || PL_egid != PL_gid) { /* (suidperl doesn't exist, in fact) */
a687059c 3159#ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
b28d0864
NIS		 3160 PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf); /* may be either wrapped or real suid */
3161 if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
a687059c 3162 ||
b28d0864 3163 (PL_egid != PL_gid && PL_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
a687059c 3164 )
b28d0864 3165 if (!PL_do_undump)
cea2e8a9 3166 Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
a687059c
LW		 3167FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
3168#endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
3169 /* not set-id, must be wrapped */
a687059c 3170 }
13281fa4 3171#endif /* DOSUID */
79072805 3172}
13281fa4 3173
76e3520e 3174STATIC void
cea2e8a9 3175S_find_beginning(pTHX)
79072805 3176{
6e72f9df 3177 register char *s, *s2;
e55ac0fa
HS		 3178#ifdef MACOS_TRADITIONAL
3179 int maclines = 0;
3180#endif
33b78306
LW		 3181
3182 /* skip forward in input to the real script? */
3183
bbce6d69 3184 forbid_setid("-x");
bf4acbe4 3185#ifdef MACOS_TRADITIONAL
084592ab 3186 /* Since the Mac OS does not honor #! arguments for us, we do it ourselves */
ac27b0f5 3187
bf4acbe4
GS		 3188 while (PL_doextract || gMacPerl_AlwaysExtract) {
3189 if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
3190 if (!gMacPerl_AlwaysExtract)
3191 Perl_croak(aTHX_ "No Perl script found in input\n");
e55ac0fa 3192
bf4acbe4
GS		 3193 if (PL_doextract) /* require explicit override ? */
3194 if (!OverrideExtract(PL_origfilename))
3195 Perl_croak(aTHX_ "User aborted script\n");
3196 else
3197 PL_doextract = FALSE;
e55ac0fa 3198
bf4acbe4
GS		 3199 /* Pater peccavi, file does not have #! */
3200 PerlIO_rewind(PL_rsfp);
e55ac0fa 3201
bf4acbe4
GS		 3202 break;
3203 }
3204#else
3280af22
NIS		 3205 while (PL_doextract) {
3206 if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch)
cea2e8a9 3207 Perl_croak(aTHX_ "No Perl script found in input\n");
bf4acbe4 3208#endif
4f0c37ba
IZ		 3209 s2 = s;
3210 if (*s == '#' && s[1] == '!' && ((s = instr(s,"perl")) || (s = instr(s2,"PERL")))) {
3280af22
NIS		 3211 PerlIO_ungetc(PL_rsfp, '\n'); /* to keep line count right */
3212 PL_doextract = FALSE;
6e72f9df 3213 while (*s && !(isSPACE (*s) || *s == '#')) s++;
3214 s2 = s;
3215 while (*s == ' ' || *s == '\t') s++;
3216 if (*s++ == '-') {
3217 while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
3218 if (strnEQ(s2-4,"perl",4))
3219 /*SUPPRESS 530*/
155aba94
GS		 3220 while ((s = moreswitches(s)))
3221 ;
33b78306 3222 }
95e8664e 3223#ifdef MACOS_TRADITIONAL
e55ac0fa
HS		 3224 /* We are always searching for the #!perl line in MacPerl,
3225 * so if we find it, still keep the line count correct
3226 * by counting lines we already skipped over
3227 */
3228 for (; maclines > 0 ; maclines--)
3229 PerlIO_ungetc(PL_rsfp, '\n');
3230
95e8664e 3231 break;
e55ac0fa
HS		 3232
3233 /* gMacPerl_AlwaysExtract is false in MPW tool */
3234 } else if (gMacPerl_AlwaysExtract) {
3235 ++maclines;
95e8664e 3236#endif
83025b21
LW		 3237 }
3238 }
3239}
3240
afe37c7d 3241
76e3520e 3242STATIC void
cea2e8a9 3243S_init_ids(pTHX)
352d5a3a 3244{
d8eceb89
JH		 3245 PL_uid = PerlProc_getuid();
3246 PL_euid = PerlProc_geteuid();
3247 PL_gid = PerlProc_getgid();
3248 PL_egid = PerlProc_getegid();
748a9306 3249#ifdef VMS
b28d0864
NIS		 3250 PL_uid |= PL_gid << 16;
3251 PL_euid |= PL_egid << 16;
748a9306 3252#endif
3280af22 3253 PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
748a9306 3254}
79072805 3255
76e3520e 3256STATIC void
cea2e8a9 3257S_forbid_setid(pTHX_ char *s)
bbce6d69 3258{
3280af22 3259 if (PL_euid != PL_uid)
cea2e8a9 3260 Perl_croak(aTHX_ "No %s allowed while running setuid", s);
3280af22 3261 if (PL_egid != PL_gid)
cea2e8a9 3262 Perl_croak(aTHX_ "No %s allowed while running setgid", s);
bbce6d69 3263}
3264
1ee4443e
IZ		 3265void
3266Perl_init_debugger(pTHX)
748a9306 3267{
1ee4443e
IZ		 3268 HV *ostash = PL_curstash;
3269
3280af22
NIS		 3270 PL_curstash = PL_debstash;
3271 PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
3272 AvREAL_off(PL_dbargs);
3273 PL_DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
3274 PL_DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
3275 PL_DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
1ee4443e 3276 sv_upgrade(GvSV(PL_DBsub), SVt_IV); /* IVX accessed if PERLDB_SUB_NN */
3280af22 3277 PL_DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
ac27b0f5 3278 sv_setiv(PL_DBsingle, 0);
3280af22 3279 PL_DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
ac27b0f5 3280 sv_setiv(PL_DBtrace, 0);
3280af22 3281 PL_DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
ac27b0f5 3282 sv_setiv(PL_DBsignal, 0);
06492da6
SF		 3283 PL_DBassertion = GvSV((gv_fetchpv("assertion", GV_ADDMULTI, SVt_PV)));
3284 sv_setiv(PL_DBassertion, 0);
1ee4443e 3285 PL_curstash = ostash;
352d5a3a
LW		 3286}
3287
2ce36478
SM		 3288#ifndef STRESS_REALLOC
3289#define REASONABLE(size) (size)
3290#else
3291#define REASONABLE(size) (1) /* unreasonable */
3292#endif
3293
11343788 3294void
cea2e8a9 3295Perl_init_stacks(pTHX)
79072805 3296{
e336de0d 3297 /* start with 128-item stack and 8K cxstack */
3280af22 3298 PL_curstackinfo = new_stackinfo(REASONABLE(128),
e336de0d 3299 REASONABLE(8192/sizeof(PERL_CONTEXT) - 1));
3280af22
NIS		 3300 PL_curstackinfo->si_type = PERLSI_MAIN;
3301 PL_curstack = PL_curstackinfo->si_stack;
3302 PL_mainstack = PL_curstack; /* remember in case we switch stacks */
79072805 3303
3280af22
NIS		 3304 PL_stack_base = AvARRAY(PL_curstack);
3305 PL_stack_sp = PL_stack_base;
3306 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
8990e307 3307
3280af22
NIS		 3308 New(50,PL_tmps_stack,REASONABLE(128),SV*);
3309 PL_tmps_floor = -1;
3310 PL_tmps_ix = -1;
3311 PL_tmps_max = REASONABLE(128);
8990e307 3312
3280af22
NIS		 3313 New(54,PL_markstack,REASONABLE(32),I32);
3314 PL_markstack_ptr = PL_markstack;
3315 PL_markstack_max = PL_markstack + REASONABLE(32);
79072805 3316
ce2f7c3b 3317 SET_MARK_OFFSET;
e336de0d 3318
3280af22
NIS		 3319 New(54,PL_scopestack,REASONABLE(32),I32);
3320 PL_scopestack_ix = 0;
3321 PL_scopestack_max = REASONABLE(32);
79072805 3322
3280af22
NIS		 3323 New(54,PL_savestack,REASONABLE(128),ANY);
3324 PL_savestack_ix = 0;
3325 PL_savestack_max = REASONABLE(128);
79072805 3326
3280af22
NIS		 3327 New(54,PL_retstack,REASONABLE(16),OP*);
3328 PL_retstack_ix = 0;
3329 PL_retstack_max = REASONABLE(16);
378cc40b 3330}
33b78306 3331
2ce36478
SM		 3332#undef REASONABLE
3333
76e3520e 3334STATIC void
cea2e8a9 3335S_nuke_stacks(pTHX)
6e72f9df 3336{
3280af22
NIS		 3337 while (PL_curstackinfo->si_next)
3338 PL_curstackinfo = PL_curstackinfo->si_next;
3339 while (PL_curstackinfo) {
3340 PERL_SI *p = PL_curstackinfo->si_prev;
bac4b2ad 3341 /* curstackinfo->si_stack got nuked by sv_free_arenas() */
3280af22
NIS		 3342 Safefree(PL_curstackinfo->si_cxstack);
3343 Safefree(PL_curstackinfo);
3344 PL_curstackinfo = p;
e336de0d 3345 }
3280af22
NIS		 3346 Safefree(PL_tmps_stack);
3347 Safefree(PL_markstack);
3348 Safefree(PL_scopestack);
3349 Safefree(PL_savestack);
3350 Safefree(PL_retstack);
378cc40b 3351}
33b78306 3352
76e3520e 3353STATIC void
cea2e8a9 3354S_init_lexer(pTHX)
8990e307 3355{
06039172 3356 PerlIO *tmpfp;
3280af22
NIS		 3357 tmpfp = PL_rsfp;
3358 PL_rsfp = Nullfp;
3359 lex_start(PL_linestr);
3360 PL_rsfp = tmpfp;
79cb57f6 3361 PL_subname = newSVpvn("main",4);
8990e307
LW		 3362}
3363
76e3520e 3364STATIC void
cea2e8a9 3365S_init_predump_symbols(pTHX)
45d8adaa 3366{
93a17b20 3367 GV *tmpgv;
af8c498a 3368 IO *io;
79072805 3369
864dbfa3 3370 sv_setpvn(get_sv("\"", TRUE), " ", 1);
3280af22
NIS		 3371 PL_stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
3372 GvMULTI_on(PL_stdingv);
af8c498a 3373 io = GvIOp(PL_stdingv);
a04651f4 3374 IoTYPE(io) = IoTYPE_RDONLY;
af8c498a 3375 IoIFP(io) = PerlIO_stdin();
adbc6bb1 3376 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
a5f75d66 3377 GvMULTI_on(tmpgv);
af8c498a 3378 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
79072805 3379
85e6fe83 3380 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
a5f75d66 3381 GvMULTI_on(tmpgv);
af8c498a 3382 io = GvIOp(tmpgv);
a04651f4 3383 IoTYPE(io) = IoTYPE_WRONLY;
af8c498a 3384 IoOFP(io) = IoIFP(io) = PerlIO_stdout();
4633a7c4 3385 setdefout(tmpgv);
adbc6bb1 3386 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
a5f75d66 3387 GvMULTI_on(tmpgv);
af8c498a 3388 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
79072805 3389
bf49b057
GS		 3390 PL_stderrgv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
3391 GvMULTI_on(PL_stderrgv);
3392 io = GvIOp(PL_stderrgv);
a04651f4 3393 IoTYPE(io) = IoTYPE_WRONLY;
af8c498a 3394 IoOFP(io) = IoIFP(io) = PerlIO_stderr();
adbc6bb1 3395 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
a5f75d66 3396 GvMULTI_on(tmpgv);
af8c498a 3397 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
79072805 3398
3280af22 3399 PL_statname = NEWSV(66,0); /* last filename we did stat on */
ab821d7f 3400
bf4acbe4
GS		 3401 if (PL_osname)
3402 Safefree(PL_osname);
3403 PL_osname = savepv(OSNAME);
79072805 3404}
33b78306 3405
a11ec5a9
RGS		 3406void
3407Perl_init_argv_symbols(pTHX_ register int argc, register char **argv)
33b78306 3408{
79072805 3409 char *s;
79072805 3410 argc--,argv++; /* skip name of script */
3280af22 3411 if (PL_doswitches) {
79072805
LW		 3412 for (; argc > 0 && **argv == '-'; argc--,argv++) {
3413 if (!argv[0][1])
3414 break;
379d538a 3415 if (argv[0][1] == '-' && !argv[0][2]) {
79072805
LW		 3416 argc--,argv++;
3417 break;
3418 }
155aba94 3419 if ((s = strchr(argv[0], '='))) {
79072805 3420 *s++ = '\0';
85e6fe83 3421 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
79072805
LW		 3422 }
3423 else
85e6fe83 3424 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
fe14fcc3 3425 }
79072805 3426 }
a11ec5a9
RGS		 3427 if ((PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV))) {
3428 GvMULTI_on(PL_argvgv);
3429 (void)gv_AVadd(PL_argvgv);
3430 av_clear(GvAVn(PL_argvgv));
3431 for (; argc > 0; argc--,argv++) {
3432 SV *sv = newSVpv(argv[0],0);
3433 av_push(GvAVn(PL_argvgv),sv);
ce81ff12
JH		 3434 if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) {
3435 if (PL_unicode & PERL_UNICODE_ARGV_FLAG)
3436 SvUTF8_on(sv);
3437 }
a05d7ebb
JH		 3438 if (PL_unicode & PERL_UNICODE_WIDESYSCALLS_FLAG) /* Sarathy? */
3439 (void)sv_utf8_decode(sv);
a11ec5a9
RGS		 3440 }
3441 }
3442}
3443
04fee9b5
NIS		 3444#ifdef HAS_PROCSELFEXE
3445/* This is a function so that we don't hold on to MAXPATHLEN
8338e367 3446 bytes of stack longer than necessary
04fee9b5
NIS		 3447 */
3448STATIC void
3449S_procself_val(pTHX_ SV *sv, char *arg0)
3450{
3451 char buf[MAXPATHLEN];
d13a6521 3452 int len = readlink(PROCSELFEXE_PATH, buf, sizeof(buf) - 1);
75745e22
TJ		 3453
3454 /* On Playstation2 Linux V1.0 (kernel 2.2.1) readlink(/proc/self/exe)
3455 includes a spurious NUL which will cause $^X to fail in system
3456 or backticks (this will prevent extensions from being built and
3457 many tests from working). readlink is not meant to add a NUL.
3458 Normal readlink works fine.
3459 */
3460 if (len > 0 && buf[len-1] == '\0') {
3461 len--;
3462 }
3463
d103ec31
JH		 3464 /* FreeBSD's implementation is acknowledged to be imperfect, sometimes
3465 returning the text "unknown" from the readlink rather than the path
78cb7c00 3466 to the executable (or returning an error from the readlink). Any valid
d103ec31
JH		 3467 path has a '/' in it somewhere, so use that to validate the result.
3468 See http://www.freebsd.org/cgi/query-pr.cgi?pr=35703
3469 */
78cb7c00 3470 if (len > 0 && memchr(buf, '/', len)) {
04fee9b5
NIS		 3471 sv_setpvn(sv,buf,len);
3472 }
3473 else {
3474 sv_setpv(sv,arg0);
3475 }
3476}
3477#endif /* HAS_PROCSELFEXE */
3478
a11ec5a9
RGS		 3479STATIC void
3480S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
3481{
3482 char *s;
3483 SV *sv;
3484 GV* tmpgv;
a11ec5a9 3485
3280af22
NIS		 3486 PL_toptarget = NEWSV(0,0);
3487 sv_upgrade(PL_toptarget, SVt_PVFM);
3488 sv_setpvn(PL_toptarget, "", 0);
3489<