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