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