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