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