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