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