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