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