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