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