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