This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
perl 5.002gamma: utils/h2xs.PL
[perl5.git] / perl.c
CommitLineData
a0d0e21e
LW
1/* perl.c
2 *
1a30305b 3 * Copyright (c) 1987-1996 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
a0d0e21e
LW
18/* Omit -- it causes too much grief on mixed systems.
19#ifdef I_UNISTD
20#include <unistd.h>
21#endif
22*/
23
4633a7c4 24dEXT char rcsid[] = "perl.c\nPatch level: ###\n";
463ee0b2 25
a687059c
LW
26#ifdef IAMSUID
27#ifndef DOSUID
28#define DOSUID
29#endif
30#endif
378cc40b 31
a687059c
LW
32#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
33#ifdef DOSUID
34#undef DOSUID
35#endif
36#endif
8d063cd8 37
a0d0e21e
LW
38static void find_beginning _((void));
39static void incpush _((char *));
748a9306 40static void init_ids _((void));
a0d0e21e
LW
41static void init_debugger _((void));
42static void init_lexer _((void));
43static void init_main_stash _((void));
44static void init_perllib _((void));
45static void init_postdump_symbols _((int, char **, char **));
46static void init_predump_symbols _((void));
47static void init_stacks _((void));
48static void open_script _((char *, bool, SV *));
49static void validate_suid _((char *));
79072805 50
93a17b20 51PerlInterpreter *
79072805
LW
52perl_alloc()
53{
93a17b20 54 PerlInterpreter *sv_interp;
79072805 55
8990e307 56 curinterp = 0;
93a17b20 57 New(53, sv_interp, 1, PerlInterpreter);
79072805
LW
58 return sv_interp;
59}
60
61void
62perl_construct( sv_interp )
93a17b20 63register PerlInterpreter *sv_interp;
79072805
LW
64{
65 if (!(curinterp = sv_interp))
66 return;
67
8990e307 68#ifdef MULTIPLICITY
93a17b20 69 Zero(sv_interp, 1, PerlInterpreter);
8990e307 70#endif
79072805
LW
71
72 /* Init the real globals? */
73 if (!linestr) {
74 linestr = NEWSV(65,80);
ed6116ce 75 sv_upgrade(linestr,SVt_PVIV);
79072805
LW
76
77 SvREADONLY_on(&sv_undef);
78
79 sv_setpv(&sv_no,No);
463ee0b2 80 SvNV(&sv_no);
79072805
LW
81 SvREADONLY_on(&sv_no);
82
83 sv_setpv(&sv_yes,Yes);
463ee0b2 84 SvNV(&sv_yes);
79072805
LW
85 SvREADONLY_on(&sv_yes);
86
c07a80fd
PP
87 nrs = newSVpv("\n", 1);
88 rs = SvREFCNT_inc(nrs);
89
79072805
LW
90#ifdef MSDOS
91 /*
92 * There is no way we can refer to them from Perl so close them to save
93 * space. The other alternative would be to provide STDAUX and STDPRN
94 * filehandles.
95 */
96 (void)fclose(stdaux);
97 (void)fclose(stdprn);
98#endif
99 }
100
8990e307 101#ifdef MULTIPLICITY
79072805 102 chopset = " \n-";
463ee0b2 103 copline = NOLINE;
79072805 104 curcop = &compiling;
1a30305b 105 dbargs = 0;
79072805
LW
106 dlmax = 128;
107 laststatval = -1;
108 laststype = OP_STAT;
109 maxscream = -1;
110 maxsysfd = MAXSYSFD;
79072805 111 rsfp = Nullfp;
463ee0b2 112 statname = Nullsv;
79072805 113 tmps_floor = -1;
79072805
LW
114#endif
115
748a9306 116 init_ids();
a0d0e21e 117 sprintf(patchlevel, "%5.3f", 5.0 + (PATCHLEVEL / 1000.0));
79072805
LW
118
119 fdpid = newAV(); /* for remembering popen pids by fd */
463ee0b2 120 pidstatus = newHV();/* for remembering status of dead pids */
8990e307
LW
121
122 init_stacks();
123 ENTER;
79072805
LW
124}
125
126void
748a9306 127perl_destruct(sv_interp)
93a17b20 128register PerlInterpreter *sv_interp;
79072805 129{
748a9306 130 int destruct_level; /* 0=none, 1=full, 2=full with checks */
8990e307 131 I32 last_sv_count;
a0d0e21e 132 HV *hv;
8990e307 133
79072805
LW
134 if (!(curinterp = sv_interp))
135 return;
748a9306
LW
136
137 destruct_level = perl_destruct_level;
4633a7c4
LW
138#ifdef DEBUGGING
139 {
140 char *s;
141 if (s = getenv("PERL_DESTRUCT_LEVEL"))
142 destruct_level = atoi(s);
143 }
144#endif
145
8990e307 146 LEAVE;
a0d0e21e
LW
147 FREETMPS;
148
149 if (sv_objcount) {
150 /* We must account for everything. First the syntax tree. */
151 if (main_root) {
152 curpad = AvARRAY(comppad);
153 op_free(main_root);
154 main_root = 0;
155 }
156 }
157 if (sv_objcount) {
158 /*
159 * Try to destruct global references. We do this first so that the
160 * destructors and destructees still exist. Some sv's might remain.
161 * Non-referenced objects are on their own.
162 */
163
164 dirty = TRUE;
165 sv_clean_objs();
8990e307
LW
166 }
167
a0d0e21e 168 if (destruct_level == 0){
8990e307 169
a0d0e21e
LW
170 DEBUG_P(debprofdump());
171
172 /* The exit() function will do everything that needs doing. */
173 return;
174 }
175
176 /* Prepare to destruct main symbol table. */
177 hv = defstash;
85e6fe83 178 defstash = 0;
a0d0e21e
LW
179 SvREFCNT_dec(hv);
180
181 FREETMPS;
182 if (destruct_level >= 2) {
183 if (scopestack_ix != 0)
184 warn("Unbalanced scopes: %d more ENTERs than LEAVEs\n", scopestack_ix);
185 if (savestack_ix != 0)
186 warn("Unbalanced saves: %d more saves than restores\n", savestack_ix);
187 if (tmps_floor != -1)
188 warn("Unbalanced tmps: %d more allocs than frees\n", tmps_floor + 1);
189 if (cxstack_ix != -1)
190 warn("Unbalanced context: %d more PUSHes than POPs\n", cxstack_ix + 1);
191 }
8990e307
LW
192
193 /* Now absolutely destruct everything, somehow or other, loops or no. */
8990e307
LW
194 last_sv_count = 0;
195 while (sv_count != 0 && sv_count != last_sv_count) {
196 last_sv_count = sv_count;
197 sv_clean_all();
198 }
199 if (sv_count != 0)
200 warn("Scalars leaked: %d\n", sv_count);
4633a7c4 201 sv_free_arenas();
a0d0e21e
LW
202
203 DEBUG_P(debprofdump());
79072805
LW
204}
205
206void
207perl_free(sv_interp)
93a17b20 208PerlInterpreter *sv_interp;
79072805
LW
209{
210 if (!(curinterp = sv_interp))
211 return;
212 Safefree(sv_interp);
213}
ecfc5424 214#if !defined(STANDARD_C) && !defined(HAS_GETENV_PROTOTYPE)
a0d0e21e
LW
215char *getenv _((char *)); /* Usually in <stdlib.h> */
216#endif
79072805
LW
217
218int
a0d0e21e 219perl_parse(sv_interp, xsinit, argc, argv, env)
93a17b20 220PerlInterpreter *sv_interp;
a0d0e21e
LW
221void (*xsinit)_((void));
222int argc;
223char **argv;
79072805 224char **env;
8d063cd8 225{
79072805 226 register SV *sv;
8d063cd8 227 register char *s;
1a30305b 228 char *scriptname = NULL;
a0d0e21e 229 VOL bool dosearch = FALSE;
13281fa4 230 char *validarg = "";
748a9306 231 AV* comppadlist;
8d063cd8 232
a687059c
LW
233#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
234#ifdef IAMSUID
235#undef IAMSUID
463ee0b2 236 croak("suidperl is no longer needed since the kernel can now execute\n\
a687059c
LW
237setuid perl scripts securely.\n");
238#endif
239#endif
240
79072805
LW
241 if (!(curinterp = sv_interp))
242 return 255;
243
ac58e20f
LW
244 origargv = argv;
245 origargc = argc;
a0d0e21e 246#ifndef VMS /* VMS doesn't have environ array */
fe14fcc3 247 origenviron = environ;
a0d0e21e
LW
248#endif
249
250 if (do_undump) {
251
252 /* Come here if running an undumped a.out. */
253
254 origfilename = savepv(argv[0]);
255 do_undump = FALSE;
256 cxstack_ix = -1; /* start label stack again */
748a9306 257 init_ids();
a0d0e21e
LW
258 init_postdump_symbols(argc,argv,env);
259 return 0;
260 }
261
262 if (main_root)
263 op_free(main_root);
264 main_root = 0;
79072805
LW
265
266 switch (setjmp(top_env)) {
267 case 1:
748a9306 268#ifdef VMS
79072805 269 statusvalue = 255;
748a9306
LW
270#else
271 statusvalue = 1;
272#endif
79072805 273 case 2:
8990e307
LW
274 curstash = defstash;
275 if (endav)
276 calllist(endav);
79072805
LW
277 return(statusvalue); /* my_exit() was called */
278 case 3:
279 fprintf(stderr, "panic: top_env\n");
8990e307 280 return 1;
79072805
LW
281 }
282
79072805
LW
283 sv_setpvn(linestr,"",0);
284 sv = newSVpv("",0); /* first used for -I flags */
8990e307 285 SAVEFREESV(sv);
79072805 286 init_main_stash();
33b78306 287 for (argc--,argv++; argc > 0; argc--,argv++) {
8d063cd8
LW
288 if (argv[0][0] != '-' || !argv[0][1])
289 break;
13281fa4
LW
290#ifdef DOSUID
291 if (*validarg)
292 validarg = " PHOOEY ";
293 else
294 validarg = argv[0];
295#endif
296 s = argv[0]+1;
8d063cd8 297 reswitch:
13281fa4 298 switch (*s) {
27e2fb84 299 case '0':
2304df62 300 case 'F':
378cc40b 301 case 'a':
33b78306 302 case 'c':
a687059c 303 case 'd':
8d063cd8 304 case 'D':
4633a7c4 305 case 'h':
33b78306 306 case 'i':
fe14fcc3 307 case 'l':
1a30305b
PP
308 case 'M':
309 case 'm':
33b78306
LW
310 case 'n':
311 case 'p':
79072805 312 case 's':
463ee0b2 313 case 'T':
33b78306
LW
314 case 'u':
315 case 'U':
316 case 'v':
317 case 'w':
318 if (s = moreswitches(s))
319 goto reswitch;
8d063cd8 320 break;
33b78306 321
8d063cd8 322 case 'e':
a687059c 323 if (euid != uid || egid != gid)
463ee0b2 324 croak("No -e allowed in setuid scripts");
8d063cd8 325 if (!e_fp) {
a0d0e21e 326 e_tmpname = savepv(TMPPATH);
a687059c 327 (void)mktemp(e_tmpname);
83025b21 328 if (!*e_tmpname)
463ee0b2 329 croak("Can't mktemp()");
8d063cd8 330 e_fp = fopen(e_tmpname,"w");
33b78306 331 if (!e_fp)
463ee0b2 332 croak("Cannot open temporary file");
8d063cd8 333 }
33b78306 334 if (argv[1]) {
8d063cd8 335 fputs(argv[1],e_fp);
33b78306
LW
336 argc--,argv++;
337 }
a687059c 338 (void)putc('\n', e_fp);
8d063cd8
LW
339 break;
340 case 'I':
463ee0b2 341 taint_not("-I");
79072805
LW
342 sv_catpv(sv,"-");
343 sv_catpv(sv,s);
344 sv_catpv(sv," ");
a687059c 345 if (*++s) {
a0d0e21e 346 av_push(GvAVn(incgv),newSVpv(s,0));
378cc40b 347 }
33b78306 348 else if (argv[1]) {
a0d0e21e 349 av_push(GvAVn(incgv),newSVpv(argv[1],0));
79072805 350 sv_catpv(sv,argv[1]);
8d063cd8 351 argc--,argv++;
79072805 352 sv_catpv(sv," ");
8d063cd8
LW
353 }
354 break;
8d063cd8 355 case 'P':
463ee0b2 356 taint_not("-P");
8d063cd8 357 preprocess = TRUE;
13281fa4 358 s++;
8d063cd8 359 goto reswitch;
378cc40b 360 case 'S':
463ee0b2 361 taint_not("-S");
378cc40b 362 dosearch = TRUE;
13281fa4 363 s++;
378cc40b 364 goto reswitch;
1a30305b
PP
365 case 'V':
366 if (!preambleav)
367 preambleav = newAV();
368 av_push(preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
369 if (*++s != ':') {
370 Sv = newSVpv("print myconfig(),'@INC: '.\"@INC\\n\"",0);
371 }
372 else {
373 Sv = newSVpv("config_vars(qw(",0);
374 sv_catpv(Sv, ++s);
375 sv_catpv(Sv, "))");
376 s += strlen(s);
377 }
378 av_push(preambleav, Sv);
c07a80fd 379 scriptname = BIT_BUCKET; /* don't look for script or read stdin */
1a30305b 380 goto reswitch;
33b78306
LW
381 case 'x':
382 doextract = TRUE;
13281fa4 383 s++;
33b78306 384 if (*s)
a0d0e21e 385 cddir = savepv(s);
33b78306 386 break;
8d063cd8
LW
387 case '-':
388 argc--,argv++;
389 goto switch_end;
390 case 0:
391 break;
392 default:
463ee0b2 393 croak("Unrecognized switch: -%s",s);
8d063cd8
LW
394 }
395 }
396 switch_end:
1a30305b
PP
397 if (!scriptname)
398 scriptname = argv[0];
8d063cd8 399 if (e_fp) {
83025b21 400 if (fflush(e_fp) || ferror(e_fp) || fclose(e_fp))
2304df62 401 croak("Can't write to temp file for -e: %s", Strerror(errno));
8d063cd8 402 argc++,argv--;
45d8adaa 403 scriptname = e_tmpname;
8d063cd8 404 }
79072805
LW
405 else if (scriptname == Nullch) {
406#ifdef MSDOS
407 if ( isatty(fileno(stdin)) )
408 moreswitches("v");
fe14fcc3 409#endif
79072805
LW
410 scriptname = "-";
411 }
fe14fcc3 412
79072805 413 init_perllib();
8d063cd8 414
79072805 415 open_script(scriptname,dosearch,sv);
8d063cd8 416
79072805 417 validate_suid(validarg);
378cc40b 418
79072805
LW
419 if (doextract)
420 find_beginning();
421
748a9306
LW
422 compcv = (CV*)NEWSV(1104,0);
423 sv_upgrade((SV *)compcv, SVt_PVCV);
424
79072805
LW
425 pad = newAV();
426 comppad = pad;
427 av_push(comppad, Nullsv);
428 curpad = AvARRAY(comppad);
93a17b20 429 padname = newAV();
8990e307
LW
430 comppad_name = padname;
431 comppad_name_fill = 0;
432 min_intro_pending = 0;
79072805
LW
433 padix = 0;
434
748a9306
LW
435 comppadlist = newAV();
436 AvREAL_off(comppadlist);
8e07c86e
AD
437 av_store(comppadlist, 0, (SV*)comppad_name);
438 av_store(comppadlist, 1, (SV*)comppad);
748a9306
LW
439 CvPADLIST(compcv) = comppadlist;
440
a0d0e21e
LW
441 if (xsinit)
442 (*xsinit)(); /* in case linked C routines want magical variables */
748a9306
LW
443#ifdef VMS
444 init_os_extras();
445#endif
93a17b20 446
93a17b20 447 init_predump_symbols();
8990e307
LW
448 if (!do_undump)
449 init_postdump_symbols(argc,argv,env);
93a17b20 450
79072805
LW
451 init_lexer();
452
453 /* now parse the script */
454
455 error_count = 0;
456 if (yyparse() || error_count) {
457 if (minus_c)
463ee0b2 458 croak("%s had compilation errors.\n", origfilename);
79072805 459 else {
463ee0b2 460 croak("Execution of %s aborted due to compilation errors.\n",
79072805 461 origfilename);
378cc40b 462 }
79072805
LW
463 }
464 curcop->cop_line = 0;
465 curstash = defstash;
466 preprocess = FALSE;
467 if (e_fp) {
468 e_fp = Nullfp;
469 (void)UNLINK(e_tmpname);
378cc40b 470 }
a687059c 471
93a17b20 472 /* now that script is parsed, we can modify record separator */
c07a80fd
PP
473 SvREFCNT_dec(rs);
474 rs = SvREFCNT_inc(nrs);
475 sv_setsv(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), rs);
45d8adaa 476
79072805
LW
477 if (do_undump)
478 my_unexec();
479
8990e307
LW
480 if (dowarn)
481 gv_check(defstash);
482
a0d0e21e
LW
483 LEAVE;
484 FREETMPS;
c07a80fd
PP
485
486#ifdef DEBUGGING_MSTATS
487 if ((s=getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
488 dump_mstats("after compilation:");
489#endif
490
a0d0e21e
LW
491 ENTER;
492 restartop = 0;
79072805
LW
493 return 0;
494}
495
496int
497perl_run(sv_interp)
93a17b20 498PerlInterpreter *sv_interp;
79072805
LW
499{
500 if (!(curinterp = sv_interp))
501 return 255;
502 switch (setjmp(top_env)) {
503 case 1:
504 cxstack_ix = -1; /* start context stack again */
505 break;
506 case 2:
507 curstash = defstash;
93a17b20
LW
508 if (endav)
509 calllist(endav);
a0d0e21e 510 FREETMPS;
c07a80fd
PP
511#ifdef DEBUGGING_MSTATS
512 if (getenv("PERL_DEBUG_MSTATS"))
513 dump_mstats("after execution: ");
514#endif
93a17b20 515 return(statusvalue); /* my_exit() was called */
79072805
LW
516 case 3:
517 if (!restartop) {
518 fprintf(stderr, "panic: restartop\n");
a0d0e21e 519 FREETMPS;
8990e307 520 return 1;
83025b21 521 }
79072805
LW
522 if (stack != mainstack) {
523 dSP;
524 SWITCHSTACK(stack, mainstack);
525 }
526 break;
8d063cd8 527 }
79072805
LW
528
529 if (!restartop) {
530 DEBUG_x(dump_all());
531 DEBUG(fprintf(stderr,"\nEXECUTING...\n\n"));
532
533 if (minus_c) {
534 fprintf(stderr,"%s syntax OK\n", origfilename);
535 my_exit(0);
536 }
a0d0e21e
LW
537 if (perldb && DBsingle)
538 sv_setiv(DBsingle, 1);
45d8adaa 539 }
79072805
LW
540
541 /* do it */
542
543 if (restartop) {
544 op = restartop;
545 restartop = 0;
546 run();
547 }
548 else if (main_start) {
549 op = main_start;
550 run();
551 }
79072805
LW
552
553 my_exit(0);
a0d0e21e 554 return 0;
79072805
LW
555}
556
557void
558my_exit(status)
748a9306 559U32 status;
79072805 560{
a0d0e21e
LW
561 register CONTEXT *cx;
562 I32 gimme;
563 SV **newsp;
564
748a9306 565 statusvalue = FIXSTATUS(status);
a0d0e21e
LW
566 if (cxstack_ix >= 0) {
567 if (cxstack_ix > 0)
568 dounwind(0);
569 POPBLOCK(cx,curpm);
570 LEAVE;
571 }
79072805
LW
572 longjmp(top_env, 2);
573}
574
a0d0e21e
LW
575SV*
576perl_get_sv(name, create)
577char* name;
578I32 create;
579{
580 GV* gv = gv_fetchpv(name, create, SVt_PV);
581 if (gv)
582 return GvSV(gv);
583 return Nullsv;
584}
585
586AV*
587perl_get_av(name, create)
588char* name;
589I32 create;
590{
591 GV* gv = gv_fetchpv(name, create, SVt_PVAV);
592 if (create)
593 return GvAVn(gv);
594 if (gv)
595 return GvAV(gv);
596 return Nullav;
597}
598
599HV*
600perl_get_hv(name, create)
601char* name;
602I32 create;
603{
604 GV* gv = gv_fetchpv(name, create, SVt_PVHV);
605 if (create)
606 return GvHVn(gv);
607 if (gv)
608 return GvHV(gv);
609 return Nullhv;
610}
611
612CV*
613perl_get_cv(name, create)
614char* name;
615I32 create;
616{
617 GV* gv = gv_fetchpv(name, create, SVt_PVCV);
618 if (create && !GvCV(gv))
619 return newSUB(start_subparse(),
620 newSVOP(OP_CONST, 0, newSVpv(name,0)),
4633a7c4 621 Nullop,
a0d0e21e
LW
622 Nullop);
623 if (gv)
624 return GvCV(gv);
625 return Nullcv;
626}
627
79072805
LW
628/* Be sure to refetch the stack pointer after calling these routines. */
629
a0d0e21e
LW
630I32
631perl_call_argv(subname, flags, argv)
8990e307 632char *subname;
a0d0e21e
LW
633I32 flags; /* See G_* flags in cop.h */
634register char **argv; /* null terminated arg list */
8990e307 635{
a0d0e21e 636 dSP;
8990e307 637
a0d0e21e
LW
638 PUSHMARK(sp);
639 if (argv) {
8990e307 640 while (*argv) {
a0d0e21e 641 XPUSHs(sv_2mortal(newSVpv(*argv,0)));
8990e307
LW
642 argv++;
643 }
a0d0e21e 644 PUTBACK;
8990e307 645 }
a0d0e21e 646 return perl_call_pv(subname, flags);
8990e307
LW
647}
648
a0d0e21e
LW
649I32
650perl_call_pv(subname, flags)
651char *subname; /* name of the subroutine */
652I32 flags; /* See G_* flags in cop.h */
653{
654 return perl_call_sv((SV*)perl_get_cv(subname, TRUE), flags);
655}
656
657I32
658perl_call_method(methname, flags)
659char *methname; /* name of the subroutine */
660I32 flags; /* See G_* flags in cop.h */
661{
662 dSP;
663 OP myop;
664 if (!op)
665 op = &myop;
666 XPUSHs(sv_2mortal(newSVpv(methname,0)));
667 PUTBACK;
668 pp_method();
669 return perl_call_sv(*stack_sp--, flags);
670}
671
672/* May be called with any of a CV, a GV, or an SV containing the name. */
673I32
674perl_call_sv(sv, flags)
675SV* sv;
676I32 flags; /* See G_* flags in cop.h */
677{
678 LOGOP myop; /* fake syntax tree node */
679 SV** sp = stack_sp;
680 I32 oldmark = TOPMARK;
681 I32 retval;
682 jmp_buf oldtop;
683 I32 oldscope;
684
685 if (flags & G_DISCARD) {
686 ENTER;
687 SAVETMPS;
688 }
689
690 SAVESPTR(op);
691 op = (OP*)&myop;
692 Zero(op, 1, LOGOP);
693 EXTEND(stack_sp, 1);
694 *++stack_sp = sv;
695 oldscope = scopestack_ix;
696
697 if (!(flags & G_NOARGS))
698 myop.op_flags = OPf_STACKED;
699 myop.op_next = Nullop;
700 myop.op_flags |= OPf_KNOW;
701 if (flags & G_ARRAY)
702 myop.op_flags |= OPf_LIST;
703
704 if (flags & G_EVAL) {
705 Copy(top_env, oldtop, 1, jmp_buf);
706
707 cLOGOP->op_other = op;
708 markstack_ptr--;
4633a7c4
LW
709 /* we're trying to emulate pp_entertry() here */
710 {
711 register CONTEXT *cx;
712 I32 gimme = GIMME;
713
714 ENTER;
715 SAVETMPS;
716
717 push_return(op->op_next);
718 PUSHBLOCK(cx, CXt_EVAL, stack_sp);
719 PUSHEVAL(cx, 0, 0);
720 eval_root = op; /* Only needed so that goto works right. */
721
722 in_eval = 1;
723 if (flags & G_KEEPERR)
724 in_eval |= 4;
725 else
726 sv_setpv(GvSV(errgv),"");
727 }
a0d0e21e
LW
728 markstack_ptr++;
729
730 restart:
731 switch (setjmp(top_env)) {
732 case 0:
733 break;
734 case 1:
748a9306 735#ifdef VMS
a0d0e21e 736 statusvalue = 255; /* XXX I don't think we use 1 anymore. */
748a9306
LW
737#else
738 statusvalue = 1;
739#endif
a0d0e21e
LW
740 /* FALL THROUGH */
741 case 2:
742 /* my_exit() was called */
743 curstash = defstash;
744 FREETMPS;
745 Copy(oldtop, top_env, 1, jmp_buf);
746 if (statusvalue)
747 croak("Callback called exit");
748 my_exit(statusvalue);
749 /* NOTREACHED */
750 case 3:
751 if (restartop) {
752 op = restartop;
753 restartop = 0;
754 goto restart;
755 }
756 stack_sp = stack_base + oldmark;
757 if (flags & G_ARRAY)
758 retval = 0;
759 else {
760 retval = 1;
761 *++stack_sp = &sv_undef;
762 }
763 goto cleanup;
764 }
765 }
766
767 if (op == (OP*)&myop)
768 op = pp_entersub();
769 if (op)
770 run();
771 retval = stack_sp - (stack_base + oldmark);
4633a7c4
LW
772 if ((flags & G_EVAL) && !(flags & G_KEEPERR))
773 sv_setpv(GvSV(errgv),"");
a0d0e21e
LW
774
775 cleanup:
776 if (flags & G_EVAL) {
777 if (scopestack_ix > oldscope) {
a0a2876f
LW
778 SV **newsp;
779 PMOP *newpm;
780 I32 gimme;
781 register CONTEXT *cx;
782 I32 optype;
783
784 POPBLOCK(cx,newpm);
785 POPEVAL(cx);
786 pop_return();
787 curpm = newpm;
788 LEAVE;
a0d0e21e
LW
789 }
790 Copy(oldtop, top_env, 1, jmp_buf);
791 }
792 if (flags & G_DISCARD) {
793 stack_sp = stack_base + oldmark;
794 retval = 0;
795 FREETMPS;
796 LEAVE;
797 }
798 return retval;
799}
800
4633a7c4 801/* Eval a string. */
8990e307 802
a0d0e21e 803I32
4633a7c4 804perl_eval_sv(sv, flags)
8990e307 805SV* sv;
4633a7c4 806I32 flags; /* See G_* flags in cop.h */
a0d0e21e
LW
807{
808 UNOP myop; /* fake syntax tree node */
4633a7c4
LW
809 SV** sp = stack_sp;
810 I32 oldmark = sp - stack_base;
811 I32 retval;
812 jmp_buf oldtop;
813 I32 oldscope;
79072805 814
4633a7c4
LW
815 if (flags & G_DISCARD) {
816 ENTER;
817 SAVETMPS;
818 }
819
79072805 820 SAVESPTR(op);
79072805 821 op = (OP*)&myop;
a0d0e21e 822 Zero(op, 1, UNOP);
4633a7c4
LW
823 EXTEND(stack_sp, 1);
824 *++stack_sp = sv;
825 oldscope = scopestack_ix;
79072805 826
4633a7c4
LW
827 if (!(flags & G_NOARGS))
828 myop.op_flags = OPf_STACKED;
79072805 829 myop.op_next = Nullop;
4633a7c4
LW
830 myop.op_flags |= OPf_KNOW;
831 if (flags & G_ARRAY)
832 myop.op_flags |= OPf_LIST;
79072805 833
4633a7c4
LW
834 Copy(top_env, oldtop, 1, jmp_buf);
835
836restart:
837 switch (setjmp(top_env)) {
838 case 0:
839 break;
840 case 1:
841#ifdef VMS
842 statusvalue = 255; /* XXX I don't think we use 1 anymore. */
843#else
844 statusvalue = 1;
845#endif
846 /* FALL THROUGH */
847 case 2:
848 /* my_exit() was called */
849 curstash = defstash;
850 FREETMPS;
851 Copy(oldtop, top_env, 1, jmp_buf);
852 if (statusvalue)
853 croak("Callback called exit");
854 my_exit(statusvalue);
855 /* NOTREACHED */
856 case 3:
857 if (restartop) {
858 op = restartop;
859 restartop = 0;
860 goto restart;
861 }
862 stack_sp = stack_base + oldmark;
863 if (flags & G_ARRAY)
864 retval = 0;
865 else {
866 retval = 1;
867 *++stack_sp = &sv_undef;
868 }
869 goto cleanup;
870 }
871
872 if (op == (OP*)&myop)
873 op = pp_entereval();
874 if (op)
463ee0b2 875 run();
4633a7c4
LW
876 retval = stack_sp - (stack_base + oldmark);
877 if ((flags & G_EVAL) && !(flags & G_KEEPERR))
878 sv_setpv(GvSV(errgv),"");
879
880 cleanup:
881 Copy(oldtop, top_env, 1, jmp_buf);
882 if (flags & G_DISCARD) {
883 stack_sp = stack_base + oldmark;
884 retval = 0;
885 FREETMPS;
886 LEAVE;
887 }
888 return retval;
889}
890
891/* Require a module. */
892
893void
894perl_require_pv(pv)
895char* pv;
896{
897 SV* sv = sv_newmortal();
898 sv_setpv(sv, "require '");
899 sv_catpv(sv, pv);
900 sv_catpv(sv, "'");
901 perl_eval_sv(sv, G_DISCARD);
79072805
LW
902}
903
79072805 904void
79072805
LW
905magicname(sym,name,namlen)
906char *sym;
907char *name;
908I32 namlen;
909{
910 register GV *gv;
911
85e6fe83 912 if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
79072805
LW
913 sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
914}
915
748a9306
LW
916#if defined(DOSISH)
917# define PERLLIB_SEP ';'
79072805 918#else
232e078e
AD
919# if defined(VMS)
920# define PERLLIB_SEP '|'
921# else
748a9306 922# define PERLLIB_SEP ':'
232e078e 923# endif
79072805
LW
924#endif
925
926static void
927incpush(p)
928char *p;
929{
930 char *s;
931
932 if (!p)
933 return;
934
935 /* Break at all separators */
936 while (*p) {
937 /* First, skip any consecutive separators */
938 while ( *p == PERLLIB_SEP ) {
939 /* Uncomment the next line for PATH semantics */
a0d0e21e 940 /* av_push(GvAVn(incgv), newSVpv(".", 1)); */
79072805
LW
941 p++;
942 }
93a17b20 943 if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
a0d0e21e 944 av_push(GvAVn(incgv), newSVpv(p, (STRLEN)(s - p)));
79072805
LW
945 p = s + 1;
946 } else {
a0d0e21e 947 av_push(GvAVn(incgv), newSVpv(p, 0));
79072805
LW
948 break;
949 }
950 }
951}
952
4633a7c4 953void
1a30305b 954usage(name) /* XXX move this out into a module ? */
4633a7c4
LW
955char *name;
956{
957 printf("\nUsage: %s [switches] [filename] [arguments]\n",name);
958 printf("\n -0[octal] specify record separator (\\0, if no argument)");
959 printf("\n -a autosplit mode with -n or -p");
960 printf("\n -c check syntax only (runs BEGIN and END blocks)");
1a30305b 961 printf("\n -d[:debugger] run scripts under debugger");
4633a7c4
LW
962 printf("\n -D[number/list] set debugging flags (argument is a bit mask or flags)");
963 printf("\n -e command one line of script, multiple -e options are allowed");
964 printf("\n [filename] can be ommitted when -e is used");
965 printf("\n -F regexp regular expression for autosplit (-a)");
966 printf("\n -i[extension] edit <> files in place (make backup if extension supplied)");
967 printf("\n -Idirectory specify include directory (may be used more then once)");
968 printf("\n -l[octal] enable line ending processing, specifies line teminator");
969 printf("\n -n assume 'while (<>) { ... }' loop arround your script");
970 printf("\n -p assume loop like -n but print line also like sed");
971 printf("\n -P run script through C preprocessor before compilation");
972#ifdef OS2
973 printf("\n -R enable REXX variable pool");
974#endif
975 printf("\n -s enable some switch parsing for switches after script name");
976 printf("\n -S look for the script using PATH environment variable");
977 printf("\n -T turn on tainting checks");
978 printf("\n -u dump core after parsing script");
979 printf("\n -U allow unsafe operations");
980 printf("\n -v print version number and patchlevel of perl");
1a30305b 981 printf("\n -V[:variable] print perl configuration information");
4633a7c4
LW
982 printf("\n -w turn warnings on for compilation of your script");
983 printf("\n -x[directory] strip off text before #!perl line and perhaps cd to directory\n");
984}
985
79072805
LW
986/* This routine handles any switches that can be given during run */
987
988char *
989moreswitches(s)
990char *s;
991{
992 I32 numlen;
c07a80fd 993 U32 rschar;
79072805
LW
994
995 switch (*s) {
996 case '0':
c07a80fd
PP
997 rschar = scan_oct(s, 4, &numlen);
998 SvREFCNT_dec(nrs);
999 if (rschar & ~((U8)~0))
1000 nrs = &sv_undef;
1001 else if (!rschar && numlen >= 2)
1002 nrs = newSVpv("", 0);
1003 else {
1004 char ch = rschar;
1005 nrs = newSVpv(&ch, 1);
79072805
LW
1006 }
1007 return s + numlen;
2304df62
AD
1008 case 'F':
1009 minus_F = TRUE;
a0d0e21e 1010 splitstr = savepv(s + 1);
2304df62
AD
1011 s += strlen(s);
1012 return s;
79072805
LW
1013 case 'a':
1014 minus_a = TRUE;
1015 s++;
1016 return s;
1017 case 'c':
1018 minus_c = TRUE;
1019 s++;
1020 return s;
1021 case 'd':
463ee0b2 1022 taint_not("-d");
4633a7c4 1023 s++;
c07a80fd 1024 if (*s == ':' || *s == '=') {
4633a7c4
LW
1025 sprintf(buf, "use Devel::%s;", ++s);
1026 s += strlen(s);
1027 my_setenv("PERL5DB",buf);
1028 }
a0d0e21e
LW
1029 if (!perldb) {
1030 perldb = TRUE;
1031 init_debugger();
1032 }
79072805
LW
1033 return s;
1034 case 'D':
1035#ifdef DEBUGGING
463ee0b2 1036 taint_not("-D");
79072805 1037 if (isALPHA(s[1])) {
8990e307 1038 static char debopts[] = "psltocPmfrxuLHXD";
79072805
LW
1039 char *d;
1040
93a17b20 1041 for (s++; *s && (d = strchr(debopts,*s)); s++)
79072805
LW
1042 debug |= 1 << (d - debopts);
1043 }
1044 else {
1045 debug = atoi(s+1);
1046 for (s++; isDIGIT(*s); s++) ;
1047 }
8990e307 1048 debug |= 0x80000000;
79072805
LW
1049#else
1050 warn("Recompile perl with -DDEBUGGING to use -D switch\n");
a0d0e21e 1051 for (s++; isALNUM(*s); s++) ;
79072805
LW
1052#endif
1053 /*SUPPRESS 530*/
1054 return s;
4633a7c4
LW
1055 case 'h':
1056 usage(origargv[0]);
1057 exit(0);
79072805
LW
1058 case 'i':
1059 if (inplace)
1060 Safefree(inplace);
a0d0e21e 1061 inplace = savepv(s+1);
79072805
LW
1062 /*SUPPRESS 530*/
1063 for (s = inplace; *s && !isSPACE(*s); s++) ;
1064 *s = '\0';
1065 break;
1066 case 'I':
463ee0b2 1067 taint_not("-I");
79072805 1068 if (*++s) {
748a9306
LW
1069 char *e;
1070 for (e = s; *e && !isSPACE(*e); e++) ;
1071 av_push(GvAVn(incgv),newSVpv(s,e-s));
1072 if (*e)
1073 return e;
79072805
LW
1074 }
1075 else
463ee0b2 1076 croak("No space allowed after -I");
79072805
LW
1077 break;
1078 case 'l':
1079 minus_l = TRUE;
1080 s++;
a0d0e21e
LW
1081 if (ors)
1082 Safefree(ors);
79072805 1083 if (isDIGIT(*s)) {
a0d0e21e 1084 ors = savepv("\n");
79072805
LW
1085 orslen = 1;
1086 *ors = scan_oct(s, 3 + (*s == '0'), &numlen);
1087 s += numlen;
1088 }
1089 else {
c07a80fd
PP
1090 if (RsPARA(nrs)) {
1091 ors = savepvn("\n\n", 2);
1092 orslen = 2;
1093 }
1094 else
1095 ors = SvPV(nrs, orslen);
79072805
LW
1096 }
1097 return s;
1a30305b
PP
1098 case 'M':
1099 taint_not("-M"); /* XXX ? */
1100 /* FALL THROUGH */
1101 case 'm':
1102 taint_not("-m"); /* XXX ? */
1103 if (*++s) {
c07a80fd
PP
1104 char *start = s;
1105 Sv = newSVpv("use ",4);
1a30305b 1106 /* We allow -M'Module qw(Foo Bar)' */
c07a80fd
PP
1107 while(isALNUM(*s) || *s==':') ++s;
1108 if (*s != '=') {
1109 sv_catpv(Sv, start);
1110 if (*(start-1) == 'm') {
1111 if (*s != '\0')
1112 croak("Can't use '%c' after -mname", *s);
1113 sv_catpv( Sv, " ()");
1114 }
1115 } else {
1116 sv_catpvn(Sv, start, s-start);
1117 sv_catpv(Sv, " qw(");
1118 sv_catpv(Sv, ++s);
1119 sv_catpv(Sv, ")");
1120 }
1a30305b 1121 s += strlen(s);
c07a80fd
PP
1122 if (preambleav == NULL)
1123 preambleav = newAV();
1124 av_push(preambleav, Sv);
1a30305b
PP
1125 }
1126 else
1127 croak("No space allowed after -%c", *(s-1));
1128 return s;
79072805
LW
1129 case 'n':
1130 minus_n = TRUE;
1131 s++;
1132 return s;
1133 case 'p':
1134 minus_p = TRUE;
1135 s++;
1136 return s;
1137 case 's':
463ee0b2 1138 taint_not("-s");
79072805
LW
1139 doswitches = TRUE;
1140 s++;
1141 return s;
463ee0b2
LW
1142 case 'T':
1143 tainting = TRUE;
1144 s++;
1145 return s;
79072805
LW
1146 case 'u':
1147 do_undump = TRUE;
1148 s++;
1149 return s;
1150 case 'U':
1151 unsafe = TRUE;
1152 s++;
1153 return s;
1154 case 'v':
a38d6535 1155 printf("\nThis is perl, version %s gamma",patchlevel);
1a30305b
PP
1156
1157#if defined(DEBUGGING) || defined(EMBED) || defined(MULTIPLICITY)
1158 fputs(" with", stdout);
1159#ifdef DEBUGGING
1160 fputs(" DEBUGGING", stdout);
1161#endif
1162#ifdef EMBED
1163 fputs(" EMBED", stdout);
1164#endif
1165#ifdef MULTIPLICITY
1166 fputs(" MULTIPLICITY", stdout);
1167#endif
1168#endif
1169
1170 fputs("\n\nCopyright 1987-1996, Larry Wall\n",stdout);
79072805
LW
1171#ifdef MSDOS
1172 fputs("MS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n",
1173 stdout);
4633a7c4 1174#endif
79072805 1175#ifdef OS2
1a30305b
PP
1176 fputs("OS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
1177 "Version 5 port Copyright (c) 1994-1995, Andreas Kaiser\n", stdout);
79072805 1178#endif
79072805 1179#ifdef atarist
1a30305b 1180 fputs("atariST series port, ++jrb bammi@cadence.com\n", stdout);
79072805
LW
1181#endif
1182 fputs("\n\
1183Perl may be copied only under the terms of either the Artistic License or the\n\
1a30305b 1184GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n",stdout);
79072805
LW
1185#ifdef MSDOS
1186 usage(origargv[0]);
1187#endif
1188 exit(0);
1189 case 'w':
1190 dowarn = TRUE;
1191 s++;
1192 return s;
a0d0e21e 1193 case '*':
79072805
LW
1194 case ' ':
1195 if (s[1] == '-') /* Additional switches on #! line. */
1196 return s+2;
1197 break;
a0d0e21e 1198 case '-':
79072805
LW
1199 case 0:
1200 case '\n':
1201 case '\t':
1202 break;
a0d0e21e
LW
1203 case 'P':
1204 if (preprocess)
1205 return s+1;
1206 /* FALL THROUGH */
79072805 1207 default:
a0d0e21e 1208 croak("Can't emulate -%.1s on #! line",s);
79072805
LW
1209 }
1210 return Nullch;
1211}
1212
1213/* compliments of Tom Christiansen */
1214
1215/* unexec() can be found in the Gnu emacs distribution */
1216
1217void
1218my_unexec()
1219{
1220#ifdef UNEXEC
1221 int status;
1222 extern int etext;
1223
1224 sprintf (buf, "%s.perldump", origfilename);
1225 sprintf (tokenbuf, "%s/perl", BIN);
1226
1227 status = unexec(buf, tokenbuf, &etext, sbrk(0), 0);
1228 if (status)
1229 fprintf(stderr, "unexec of %s into %s failed!\n", tokenbuf, buf);
a0d0e21e 1230 exit(status);
79072805
LW
1231#else
1232 ABORT(); /* for use with undump */
1233#endif
1234}
1235
1236static void
1237init_main_stash()
1238{
463ee0b2
LW
1239 GV *gv;
1240 curstash = defstash = newHV();
79072805 1241 curstname = newSVpv("main",4);
adbc6bb1
LW
1242 gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
1243 SvREFCNT_dec(GvHV(gv));
1244 GvHV(gv) = (HV*)SvREFCNT_inc(defstash);
463ee0b2 1245 SvREADONLY_on(gv);
a0d0e21e 1246 HvNAME(defstash) = savepv("main");
85e6fe83 1247 incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
79072805 1248 SvMULTI_on(incgv);
a0d0e21e 1249 defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
4633a7c4
LW
1250 errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
1251 SvMULTI_on(errgv);
8990e307
LW
1252 curstash = defstash;
1253 compiling.cop_stash = defstash;
adbc6bb1 1254 debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
4633a7c4
LW
1255 /* We must init $/ before switches are processed. */
1256 sv_setpvn(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), "\n", 1);
79072805
LW
1257}
1258
a0d0e21e
LW
1259#ifdef CAN_PROTOTYPE
1260static void
1261open_script(char *scriptname, bool dosearch, SV *sv)
1262#else
79072805
LW
1263static void
1264open_script(scriptname,dosearch,sv)
1265char *scriptname;
1266bool dosearch;
1267SV *sv;
a0d0e21e 1268#endif
79072805
LW
1269{
1270 char *xfound = Nullch;
1271 char *xfailed = Nullch;
1272 register char *s;
1273 I32 len;
a38d6535
LW
1274 int retval;
1275#if defined(DOSISH) && !defined(OS2) && !defined(atarist)
1276#define SEARCH_EXTS ".bat", ".cmd", NULL
1277#endif
1278 /* additional extensions to try in each dir if scriptname not found */
1279#ifdef SEARCH_EXTS
1280 char *ext[] = { SEARCH_EXTS };
1281 int extidx = (strchr(scriptname,'.')) ? -1 : 0; /* has ext already */
1282#endif
79072805 1283
c07a80fd
PP
1284#ifdef VMS
1285 if (dosearch && !strpbrk(scriptname,":[</") && (my_getenv("DCL$PATH"))) {
1286 int idx = 0;
1287
1288 while (my_trnlnm("DCL$PATH",tokenbuf,idx++)) {
1289 strcat(tokenbuf,scriptname);
1290#else /* !VMS */
93a17b20 1291 if (dosearch && !strchr(scriptname, '/') && (s = getenv("PATH"))) {
79072805
LW
1292
1293 bufend = s + strlen(s);
1294 while (*s) {
1295#ifndef DOSISH
1296 s = cpytill(tokenbuf,s,bufend,':',&len);
1297#else
1298#ifdef atarist
1299 for (len = 0; *s && *s != ',' && *s != ';'; tokenbuf[len++] = *s++);
1300 tokenbuf[len] = '\0';
1301#else
1302 for (len = 0; *s && *s != ';'; tokenbuf[len++] = *s++);
1303 tokenbuf[len] = '\0';
1304#endif
1305#endif
1306 if (*s)
1307 s++;
1308#ifndef DOSISH
1309 if (len && tokenbuf[len-1] != '/')
1310#else
1311#ifdef atarist
1312 if (len && ((tokenbuf[len-1] != '\\') && (tokenbuf[len-1] != '/')))
1313#else
1314 if (len && tokenbuf[len-1] != '\\')
1315#endif
1316#endif
1317 (void)strcat(tokenbuf+len,"/");
1318 (void)strcat(tokenbuf+len,scriptname);
c07a80fd 1319#endif /* !VMS */
a38d6535
LW
1320
1321#ifdef SEARCH_EXTS
1322 len = strlen(tokenbuf);
1323 if (extidx > 0) /* reset after previous loop */
1324 extidx = 0;
1325 do {
1326#endif
1327 DEBUG_p(fprintf(stderr,"Looking for %s\n",tokenbuf));
1328 retval = Stat(tokenbuf,&statbuf);
1329#ifdef SEARCH_EXTS
1330 } while ( retval < 0 /* not there */
1331 && extidx>=0 && ext[extidx] /* try an extension? */
1332 && strcpy(tokenbuf+len, ext[extidx++])
1333 );
1334#endif
1335 if (retval < 0)
79072805
LW
1336 continue;
1337 if (S_ISREG(statbuf.st_mode)
1338 && cando(S_IRUSR,TRUE,&statbuf) && cando(S_IXUSR,TRUE,&statbuf)) {
1339 xfound = tokenbuf; /* bingo! */
1340 break;
1341 }
1342 if (!xfailed)
a0d0e21e 1343 xfailed = savepv(tokenbuf);
79072805
LW
1344 }
1345 if (!xfound)
463ee0b2 1346 croak("Can't execute %s", xfailed ? xfailed : scriptname );
79072805
LW
1347 if (xfailed)
1348 Safefree(xfailed);
1349 scriptname = xfound;
1350 }
1351
a0d0e21e 1352 origfilename = savepv(e_fp ? "-e" : scriptname);
79072805
LW
1353 curcop->cop_filegv = gv_fetchfile(origfilename);
1354 if (strEQ(origfilename,"-"))
1355 scriptname = "";
1356 if (preprocess) {
1357 char *cpp = CPPSTDIN;
1358
1359 if (strEQ(cpp,"cppstdin"))
1360 sprintf(tokenbuf, "%s/%s", SCRIPTDIR, cpp);
1361 else
1362 sprintf(tokenbuf, "%s", cpp);
1363 sv_catpv(sv,"-I");
fed7345c 1364 sv_catpv(sv,PRIVLIB_EXP);
79072805
LW
1365#ifdef MSDOS
1366 (void)sprintf(buf, "\
1367sed %s -e \"/^[^#]/b\" \
1368 -e \"/^#[ ]*include[ ]/b\" \
1369 -e \"/^#[ ]*define[ ]/b\" \
1370 -e \"/^#[ ]*if[ ]/b\" \
1371 -e \"/^#[ ]*ifdef[ ]/b\" \
1372 -e \"/^#[ ]*ifndef[ ]/b\" \
1373 -e \"/^#[ ]*else/b\" \
1374 -e \"/^#[ ]*elif[ ]/b\" \
1375 -e \"/^#[ ]*undef[ ]/b\" \
1376 -e \"/^#[ ]*endif/b\" \
1377 -e \"s/^#.*//\" \
1378 %s | %s -C %s %s",
1379 (doextract ? "-e \"1,/^#/d\n\"" : ""),
1380#else
1381 (void)sprintf(buf, "\
1382%s %s -e '/^[^#]/b' \
1383 -e '/^#[ ]*include[ ]/b' \
1384 -e '/^#[ ]*define[ ]/b' \
1385 -e '/^#[ ]*if[ ]/b' \
1386 -e '/^#[ ]*ifdef[ ]/b' \
1387 -e '/^#[ ]*ifndef[ ]/b' \
1388 -e '/^#[ ]*else/b' \
1389 -e '/^#[ ]*elif[ ]/b' \
1390 -e '/^#[ ]*undef[ ]/b' \
1391 -e '/^#[ ]*endif/b' \
1392 -e 's/^[ ]*#.*//' \
1393 %s | %s -C %s %s",
1394#ifdef LOC_SED
1395 LOC_SED,
1396#else
1397 "sed",
1398#endif
1399 (doextract ? "-e '1,/^#/d\n'" : ""),
1400#endif
463ee0b2 1401 scriptname, tokenbuf, SvPV(sv, na), CPPMINUS);
79072805
LW
1402 doextract = FALSE;
1403#ifdef IAMSUID /* actually, this is caught earlier */
1404 if (euid != uid && !euid) { /* if running suidperl */
1405#ifdef HAS_SETEUID
1406 (void)seteuid(uid); /* musn't stay setuid root */
1407#else
1408#ifdef HAS_SETREUID
85e6fe83
LW
1409 (void)setreuid((Uid_t)-1, uid);
1410#else
1411#ifdef HAS_SETRESUID
1412 (void)setresuid((Uid_t)-1, uid, (Uid_t)-1);
79072805
LW
1413#else
1414 setuid(uid);
1415#endif
1416#endif
85e6fe83 1417#endif
79072805 1418 if (geteuid() != uid)
463ee0b2 1419 croak("Can't do seteuid!\n");
79072805
LW
1420 }
1421#endif /* IAMSUID */
1422 rsfp = my_popen(buf,"r");
1423 }
1424 else if (!*scriptname) {
463ee0b2 1425 taint_not("program input from stdin");
79072805
LW
1426 rsfp = stdin;
1427 }
1428 else
1429 rsfp = fopen(scriptname,"r");
45d8adaa 1430 if ((FILE*)rsfp == Nullfp) {
13281fa4 1431#ifdef DOSUID
a687059c 1432#ifndef IAMSUID /* in case script is not readable before setuid */
a0d0e21e 1433 if (euid && Stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
13281fa4 1434 statbuf.st_mode & (S_ISUID|S_ISGID)) {
27e2fb84 1435 (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
a687059c 1436 execv(buf, origargv); /* try again */
463ee0b2 1437 croak("Can't do setuid\n");
13281fa4
LW
1438 }
1439#endif
1440#endif
463ee0b2 1441 croak("Can't open perl script \"%s\": %s\n",
2304df62 1442 SvPVX(GvSV(curcop->cop_filegv)), Strerror(errno));
13281fa4 1443 }
79072805 1444}
8d063cd8 1445
79072805
LW
1446static void
1447validate_suid(validarg)
1448char *validarg;
1449{
13281fa4
LW
1450 /* do we need to emulate setuid on scripts? */
1451
1452 /* This code is for those BSD systems that have setuid #! scripts disabled
1453 * in the kernel because of a security problem. Merely defining DOSUID
1454 * in perl will not fix that problem, but if you have disabled setuid
1455 * scripts in the kernel, this will attempt to emulate setuid and setgid
1456 * on scripts that have those now-otherwise-useless bits set. The setuid
27e2fb84
LW
1457 * root version must be called suidperl or sperlN.NNN. If regular perl
1458 * discovers that it has opened a setuid script, it calls suidperl with
1459 * the same argv that it had. If suidperl finds that the script it has
1460 * just opened is NOT setuid root, it sets the effective uid back to the
1461 * uid. We don't just make perl setuid root because that loses the
1462 * effective uid we had before invoking perl, if it was different from the
1463 * uid.
13281fa4
LW
1464 *
1465 * DOSUID must be defined in both perl and suidperl, and IAMSUID must
1466 * be defined in suidperl only. suidperl must be setuid root. The
1467 * Configure script will set this up for you if you want it.
1468 */
a687059c 1469
13281fa4 1470#ifdef DOSUID
a0d0e21e
LW
1471 char *s;
1472
1473 if (Fstat(fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */
463ee0b2 1474 croak("Can't stat script \"%s\"",origfilename);
13281fa4 1475 if (statbuf.st_mode & (S_ISUID|S_ISGID)) {
79072805 1476 I32 len;
13281fa4 1477
a687059c 1478#ifdef IAMSUID
fe14fcc3 1479#ifndef HAS_SETREUID
a687059c
LW
1480 /* On this access check to make sure the directories are readable,
1481 * there is actually a small window that the user could use to make
1482 * filename point to an accessible directory. So there is a faint
1483 * chance that someone could execute a setuid script down in a
1484 * non-accessible directory. I don't know what to do about that.
1485 * But I don't think it's too important. The manual lies when
1486 * it says access() is useful in setuid programs.
1487 */
463ee0b2
LW
1488 if (access(SvPVX(GvSV(curcop->cop_filegv)),1)) /*double check*/
1489 croak("Permission denied");
a687059c
LW
1490#else
1491 /* If we can swap euid and uid, then we can determine access rights
1492 * with a simple stat of the file, and then compare device and
1493 * inode to make sure we did stat() on the same file we opened.
1494 * Then we just have to make sure he or she can execute it.
1495 */
1496 {
1497 struct stat tmpstatbuf;
1498
85e6fe83
LW
1499 if (
1500#ifdef HAS_SETREUID
1501 setreuid(euid,uid) < 0
a0d0e21e
LW
1502#else
1503# if HAS_SETRESUID
85e6fe83 1504 setresuid(euid,uid,(Uid_t)-1) < 0
a0d0e21e 1505# endif
85e6fe83
LW
1506#endif
1507 || getuid() != euid || geteuid() != uid)
463ee0b2 1508 croak("Can't swap uid and euid"); /* really paranoid */
a0d0e21e 1509 if (Stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0)
463ee0b2 1510 croak("Permission denied"); /* testing full pathname here */
a687059c
LW
1511 if (tmpstatbuf.st_dev != statbuf.st_dev ||
1512 tmpstatbuf.st_ino != statbuf.st_ino) {
1513 (void)fclose(rsfp);
79072805 1514 if (rsfp = my_popen("/bin/mail root","w")) { /* heh, heh */
a687059c
LW
1515 fprintf(rsfp,
1516"User %d tried to run dev %d ino %d in place of dev %d ino %d!\n\
1517(Filename of set-id script was %s, uid %d gid %d.)\n\nSincerely,\nperl\n",
1518 uid,tmpstatbuf.st_dev, tmpstatbuf.st_ino,
1519 statbuf.st_dev, statbuf.st_ino,
463ee0b2 1520 SvPVX(GvSV(curcop->cop_filegv)),
20188a90 1521 statbuf.st_uid, statbuf.st_gid);
79072805 1522 (void)my_pclose(rsfp);
a687059c 1523 }
463ee0b2 1524 croak("Permission denied\n");
a687059c 1525 }
85e6fe83
LW
1526 if (
1527#ifdef HAS_SETREUID
1528 setreuid(uid,euid) < 0
a0d0e21e
LW
1529#else
1530# if defined(HAS_SETRESUID)
85e6fe83 1531 setresuid(uid,euid,(Uid_t)-1) < 0
a0d0e21e 1532# endif
85e6fe83
LW
1533#endif
1534 || getuid() != uid || geteuid() != euid)
463ee0b2 1535 croak("Can't reswap uid and euid");
27e2fb84 1536 if (!cando(S_IXUSR,FALSE,&statbuf)) /* can real uid exec? */
463ee0b2 1537 croak("Permission denied\n");
a687059c 1538 }
fe14fcc3 1539#endif /* HAS_SETREUID */
a687059c
LW
1540#endif /* IAMSUID */
1541
27e2fb84 1542 if (!S_ISREG(statbuf.st_mode))
463ee0b2 1543 croak("Permission denied");
27e2fb84 1544 if (statbuf.st_mode & S_IWOTH)
463ee0b2 1545 croak("Setuid/gid script is writable by world");
13281fa4 1546 doswitches = FALSE; /* -s is insecure in suid */
79072805 1547 curcop->cop_line++;
13281fa4
LW
1548 if (fgets(tokenbuf,sizeof tokenbuf, rsfp) == Nullch ||
1549 strnNE(tokenbuf,"#!",2) ) /* required even on Sys V */
463ee0b2 1550 croak("No #! line");
663a0e37
LW
1551 s = tokenbuf+2;
1552 if (*s == ' ') s++;
45d8adaa 1553 while (!isSPACE(*s)) s++;
27e2fb84 1554 if (strnNE(s-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
463ee0b2 1555 croak("Not a perl script");
a687059c 1556 while (*s == ' ' || *s == '\t') s++;
13281fa4
LW
1557 /*
1558 * #! arg must be what we saw above. They can invoke it by
1559 * mentioning suidperl explicitly, but they may not add any strange
1560 * arguments beyond what #! says if they do invoke suidperl that way.
1561 */
1562 len = strlen(validarg);
1563 if (strEQ(validarg," PHOOEY ") ||
45d8adaa 1564 strnNE(s,validarg,len) || !isSPACE(s[len]))
463ee0b2 1565 croak("Args must match #! line");
a687059c
LW
1566
1567#ifndef IAMSUID
1568 if (euid != uid && (statbuf.st_mode & S_ISUID) &&
1569 euid == statbuf.st_uid)
1570 if (!do_undump)
463ee0b2 1571 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
a687059c
LW
1572FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
1573#endif /* IAMSUID */
13281fa4
LW
1574
1575 if (euid) { /* oops, we're not the setuid root perl */
a687059c 1576 (void)fclose(rsfp);
13281fa4 1577#ifndef IAMSUID
27e2fb84 1578 (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
a687059c 1579 execv(buf, origargv); /* try again */
13281fa4 1580#endif
463ee0b2 1581 croak("Can't do setuid\n");
13281fa4
LW
1582 }
1583
83025b21 1584 if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) {
fe14fcc3 1585#ifdef HAS_SETEGID
a687059c
LW
1586 (void)setegid(statbuf.st_gid);
1587#else
fe14fcc3 1588#ifdef HAS_SETREGID
85e6fe83
LW
1589 (void)setregid((Gid_t)-1,statbuf.st_gid);
1590#else
1591#ifdef HAS_SETRESGID
1592 (void)setresgid((Gid_t)-1,statbuf.st_gid,(Gid_t)-1);
a687059c
LW
1593#else
1594 setgid(statbuf.st_gid);
1595#endif
1596#endif
85e6fe83 1597#endif
83025b21 1598 if (getegid() != statbuf.st_gid)
463ee0b2 1599 croak("Can't do setegid!\n");
83025b21 1600 }
a687059c
LW
1601 if (statbuf.st_mode & S_ISUID) {
1602 if (statbuf.st_uid != euid)
fe14fcc3 1603#ifdef HAS_SETEUID
a687059c
LW
1604 (void)seteuid(statbuf.st_uid); /* all that for this */
1605#else
fe14fcc3 1606#ifdef HAS_SETREUID
85e6fe83
LW
1607 (void)setreuid((Uid_t)-1,statbuf.st_uid);
1608#else
1609#ifdef HAS_SETRESUID
1610 (void)setresuid((Uid_t)-1,statbuf.st_uid,(Uid_t)-1);
a687059c
LW
1611#else
1612 setuid(statbuf.st_uid);
1613#endif
1614#endif
85e6fe83 1615#endif
83025b21 1616 if (geteuid() != statbuf.st_uid)
463ee0b2 1617 croak("Can't do seteuid!\n");
a687059c 1618 }
83025b21 1619 else if (uid) { /* oops, mustn't run as root */
fe14fcc3 1620#ifdef HAS_SETEUID
85e6fe83 1621 (void)seteuid((Uid_t)uid);
a687059c 1622#else
fe14fcc3 1623#ifdef HAS_SETREUID
85e6fe83 1624 (void)setreuid((Uid_t)-1,(Uid_t)uid);
a687059c 1625#else
85e6fe83
LW
1626#ifdef HAS_SETRESUID
1627 (void)setresuid((Uid_t)-1,(Uid_t)uid,(Uid_t)-1);
1628#else
1629 setuid((Uid_t)uid);
1630#endif
a687059c
LW
1631#endif
1632#endif
83025b21 1633 if (geteuid() != uid)
463ee0b2 1634 croak("Can't do seteuid!\n");
83025b21 1635 }
748a9306 1636 init_ids();
27e2fb84 1637 if (!cando(S_IXUSR,TRUE,&statbuf))
463ee0b2 1638 croak("Permission denied\n"); /* they can't do this */
13281fa4
LW
1639 }
1640#ifdef IAMSUID
1641 else if (preprocess)
463ee0b2 1642 croak("-P not allowed for setuid/setgid script\n");
13281fa4 1643 else
463ee0b2 1644 croak("Script is not setuid/setgid in suidperl\n");
13281fa4 1645#endif /* IAMSUID */
a687059c 1646#else /* !DOSUID */
a687059c
LW
1647 if (euid != uid || egid != gid) { /* (suidperl doesn't exist, in fact) */
1648#ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
a0d0e21e 1649 Fstat(fileno(rsfp),&statbuf); /* may be either wrapped or real suid */
a687059c
LW
1650 if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
1651 ||
1652 (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
1653 )
1654 if (!do_undump)
463ee0b2 1655 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
a687059c
LW
1656FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
1657#endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
1658 /* not set-id, must be wrapped */
a687059c 1659 }
13281fa4 1660#endif /* DOSUID */
79072805 1661}
13281fa4 1662
79072805
LW
1663static void
1664find_beginning()
1665{
79072805 1666 register char *s;
33b78306
LW
1667
1668 /* skip forward in input to the real script? */
1669
463ee0b2 1670 taint_not("-x");
33b78306 1671 while (doextract) {
79072805 1672 if ((s = sv_gets(linestr, rsfp, 0)) == Nullch)
463ee0b2 1673 croak("No Perl script found in input\n");
33b78306
LW
1674 if (*s == '#' && s[1] == '!' && instr(s,"perl")) {
1675 ungetc('\n',rsfp); /* to keep line count right */
1676 doextract = FALSE;
1677 if (s = instr(s,"perl -")) {
1678 s += 6;
45d8adaa 1679 /*SUPPRESS 530*/
33b78306
LW
1680 while (s = moreswitches(s)) ;
1681 }
79072805 1682 if (cddir && chdir(cddir) < 0)
463ee0b2 1683 croak("Can't chdir to %s",cddir);
83025b21
LW
1684 }
1685 }
1686}
1687
79072805 1688static void
748a9306 1689init_ids()
352d5a3a 1690{
748a9306
LW
1691 uid = (int)getuid();
1692 euid = (int)geteuid();
1693 gid = (int)getgid();
1694 egid = (int)getegid();
1695#ifdef VMS
1696 uid |= gid << 16;
1697 euid |= egid << 16;
1698#endif
4633a7c4 1699 tainting |= (uid && (euid != uid || egid != gid));
748a9306 1700}
79072805 1701
748a9306
LW
1702static void
1703init_debugger()
1704{
79072805 1705 curstash = debstash;
748a9306 1706 dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
79072805 1707 AvREAL_off(dbargs);
a0d0e21e
LW
1708 DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
1709 DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
748a9306
LW
1710 DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
1711 DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
c07a80fd 1712 sv_setiv(DBsingle, 0);
748a9306 1713 DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
c07a80fd 1714 sv_setiv(DBtrace, 0);
748a9306 1715 DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
c07a80fd 1716 sv_setiv(DBsignal, 0);
79072805 1717 curstash = defstash;
352d5a3a
LW
1718}
1719
79072805 1720static void
8990e307 1721init_stacks()
79072805
LW
1722{
1723 stack = newAV();
1724 mainstack = stack; /* remember in case we switch stacks */
1725 AvREAL_off(stack); /* not a real array */
a0d0e21e 1726 av_extend(stack,127);
79072805
LW
1727
1728 stack_base = AvARRAY(stack);
1729 stack_sp = stack_base;
8990e307 1730 stack_max = stack_base + 127;
79072805 1731
a0d0e21e 1732 New(54,markstack,64,I32);
79072805
LW
1733 markstack_ptr = markstack;
1734 markstack_max = markstack + 64;
1735
a0d0e21e 1736 New(54,scopestack,32,I32);
79072805
LW
1737 scopestack_ix = 0;
1738 scopestack_max = 32;
1739
1740 New(54,savestack,128,ANY);
1741 savestack_ix = 0;
1742 savestack_max = 128;
1743
1744 New(54,retstack,16,OP*);
1745 retstack_ix = 0;
1746 retstack_max = 16;
8d063cd8 1747
a38d6535 1748 New(50,cxstack,129,CONTEXT); /* XXX should fix CXINC macro */
8990e307
LW
1749 cxstack_ix = -1;
1750 cxstack_max = 128;
1751
1752 New(50,tmps_stack,128,SV*);
1753 tmps_ix = -1;
1754 tmps_max = 128;
1755
79072805
LW
1756 DEBUG( {
1757 New(51,debname,128,char);
1758 New(52,debdelim,128,char);
1759 } )
378cc40b 1760}
33b78306 1761
a0d0e21e 1762static FILE *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
79072805 1763static void
8990e307
LW
1764init_lexer()
1765{
a0d0e21e 1766 tmpfp = rsfp;
8990e307
LW
1767
1768 lex_start(linestr);
1769 rsfp = tmpfp;
1770 subname = newSVpv("main",4);
1771}
1772
1773static void
79072805 1774init_predump_symbols()
45d8adaa 1775{
93a17b20 1776 GV *tmpgv;
a0d0e21e 1777 GV *othergv;
79072805 1778
85e6fe83 1779 sv_setpvn(GvSV(gv_fetchpv("\"", TRUE, SVt_PV)), " ", 1);
79072805 1780
85e6fe83 1781 stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
79072805 1782 SvMULTI_on(stdingv);
a0d0e21e 1783 IoIFP(GvIOp(stdingv)) = stdin;
adbc6bb1 1784 tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
a0d0e21e 1785 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(stdingv));
79072805
LW
1786 SvMULTI_on(tmpgv);
1787
85e6fe83 1788 tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
79072805 1789 SvMULTI_on(tmpgv);
a0d0e21e 1790 IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = stdout;
4633a7c4 1791 setdefout(tmpgv);
adbc6bb1 1792 tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
a0d0e21e 1793 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(defoutgv));
79072805
LW
1794 SvMULTI_on(tmpgv);
1795
a0d0e21e
LW
1796 othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
1797 SvMULTI_on(othergv);
1798 IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = stderr;
adbc6bb1 1799 tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
a0d0e21e 1800 GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv));
79072805 1801 SvMULTI_on(tmpgv);
79072805
LW
1802
1803 statname = NEWSV(66,0); /* last filename we did stat on */
79072805 1804}
33b78306 1805
79072805
LW
1806static void
1807init_postdump_symbols(argc,argv,env)
1808register int argc;
1809register char **argv;
1810register char **env;
33b78306 1811{
79072805
LW
1812 char *s;
1813 SV *sv;
1814 GV* tmpgv;
fe14fcc3 1815
79072805
LW
1816 argc--,argv++; /* skip name of script */
1817 if (doswitches) {
1818 for (; argc > 0 && **argv == '-'; argc--,argv++) {
1819 if (!argv[0][1])
1820 break;
1821 if (argv[0][1] == '-') {
1822 argc--,argv++;
1823 break;
1824 }
93a17b20 1825 if (s = strchr(argv[0], '=')) {
79072805 1826 *s++ = '\0';
85e6fe83 1827 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
79072805
LW
1828 }
1829 else
85e6fe83 1830 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
fe14fcc3 1831 }
79072805
LW
1832 }
1833 toptarget = NEWSV(0,0);
1834 sv_upgrade(toptarget, SVt_PVFM);
1835 sv_setpvn(toptarget, "", 0);
748a9306 1836 bodytarget = NEWSV(0,0);
79072805
LW
1837 sv_upgrade(bodytarget, SVt_PVFM);
1838 sv_setpvn(bodytarget, "", 0);
1839 formtarget = bodytarget;
1840
79072805 1841 tainted = 1;
85e6fe83 1842 if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
79072805
LW
1843 sv_setpv(GvSV(tmpgv),origfilename);
1844 magicname("0", "0", 1);
1845 }
85e6fe83 1846 if (tmpgv = gv_fetchpv("\024",TRUE, SVt_PV))
79072805 1847 time(&basetime);
85e6fe83 1848 if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
79072805 1849 sv_setpv(GvSV(tmpgv),origargv[0]);
85e6fe83 1850 if (argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
79072805
LW
1851 SvMULTI_on(argvgv);
1852 (void)gv_AVadd(argvgv);
1853 av_clear(GvAVn(argvgv));
1854 for (; argc > 0; argc--,argv++) {
a0d0e21e 1855 av_push(GvAVn(argvgv),newSVpv(argv[0],0));
79072805
LW
1856 }
1857 }
85e6fe83 1858 if (envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
79072805
LW
1859 HV *hv;
1860 SvMULTI_on(envgv);
1861 hv = GvHVn(envgv);
463ee0b2 1862 hv_clear(hv);
a0d0e21e 1863#ifndef VMS /* VMS doesn't have environ array */
4633a7c4
LW
1864 /* Note that if the supplied env parameter is actually a copy
1865 of the global environ then it may now point to free'd memory
1866 if the environment has been modified since. To avoid this
1867 problem we treat env==NULL as meaning 'use the default'
1868 */
1869 if (!env)
1870 env = environ;
8990e307 1871 if (env != environ) {
79072805 1872 environ[0] = Nullch;
8990e307
LW
1873 hv_magic(hv, envgv, 'E');
1874 }
79072805 1875 for (; *env; env++) {
93a17b20 1876 if (!(s = strchr(*env,'=')))
79072805
LW
1877 continue;
1878 *s++ = '\0';
1879 sv = newSVpv(s--,0);
85e6fe83 1880 sv_magic(sv, sv, 'e', *env, s - *env);
79072805
LW
1881 (void)hv_store(hv, *env, s - *env, sv, 0);
1882 *s = '=';
fe14fcc3 1883 }
4550b24a
PP
1884#endif
1885#ifdef DYNAMIC_ENV_FETCH
1886 HvNAME(hv) = savepv(ENV_HV_NAME);
1887#endif
f511e57f 1888 hv_magic(hv, envgv, 'E');
79072805 1889 }
79072805 1890 tainted = 0;
85e6fe83 1891 if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
79072805
LW
1892 sv_setiv(GvSV(tmpgv),(I32)getpid());
1893
33b78306 1894}
34de22dd 1895
79072805
LW
1896static void
1897init_perllib()
34de22dd 1898{
85e6fe83
LW
1899 char *s;
1900 if (!tainting) {
1901 s = getenv("PERL5LIB");
1902 if (s)
1903 incpush(s);
1904 else
1905 incpush(getenv("PERLLIB"));
1906 }
34de22dd 1907
4633a7c4
LW
1908#ifdef APPLLIB_EXP
1909 incpush(APPLLIB_EXP);
16d20bd9 1910#endif
4633a7c4 1911
fed7345c
AD
1912#ifdef ARCHLIB_EXP
1913 incpush(ARCHLIB_EXP);
a0d0e21e 1914#endif
fed7345c
AD
1915#ifndef PRIVLIB_EXP
1916#define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
34de22dd 1917#endif
fed7345c 1918 incpush(PRIVLIB_EXP);
4633a7c4
LW
1919
1920#ifdef SITEARCH_EXP
1921 incpush(SITEARCH_EXP);
1922#endif
1923#ifdef SITELIB_EXP
1924 incpush(SITELIB_EXP);
1925#endif
1926#ifdef OLDARCHLIB_EXP /* 5.00[01] compatibility */
1927 incpush(OLDARCHLIB_EXP);
1928#endif
a0d0e21e 1929
4633a7c4
LW
1930 if (!tainting)
1931 incpush(".");
34de22dd 1932}
93a17b20
LW
1933
1934void
1935calllist(list)
1936AV* list;
1937{
93a17b20 1938 jmp_buf oldtop;
a0d0e21e
LW
1939 STRLEN len;
1940 line_t oldline = curcop->cop_line;
93a17b20 1941
93a17b20
LW
1942 Copy(top_env, oldtop, 1, jmp_buf);
1943
8990e307
LW
1944 while (AvFILL(list) >= 0) {
1945 CV *cv = (CV*)av_shift(list);
93a17b20 1946
8990e307 1947 SAVEFREESV(cv);
a0d0e21e 1948
85e6fe83 1949 switch (setjmp(top_env)) {
748a9306 1950 case 0: {
4633a7c4 1951 SV* atsv = GvSV(errgv);
748a9306
LW
1952 PUSHMARK(stack_sp);
1953 perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
1954 (void)SvPV(atsv, len);
1955 if (len) {
1956 Copy(oldtop, top_env, 1, jmp_buf);
1957 curcop = &compiling;
1958 curcop->cop_line = oldline;
1959 if (list == beginav)
1960 sv_catpv(atsv, "BEGIN failed--compilation aborted");
1961 else
1962 sv_catpv(atsv, "END failed--cleanup aborted");
1963 croak("%s", SvPVX(atsv));
1964 }
a0d0e21e 1965 }
85e6fe83
LW
1966 break;
1967 case 1:
748a9306 1968#ifdef VMS
85e6fe83 1969 statusvalue = 255; /* XXX I don't think we use 1 anymore. */
748a9306
LW
1970#else
1971 statusvalue = 1;
1972#endif
85e6fe83
LW
1973 /* FALL THROUGH */
1974 case 2:
1975 /* my_exit() was called */
1976 curstash = defstash;
1977 if (endav)
1978 calllist(endav);
a0d0e21e
LW
1979 FREETMPS;
1980 Copy(oldtop, top_env, 1, jmp_buf);
1981 curcop = &compiling;
1982 curcop->cop_line = oldline;
85e6fe83
LW
1983 if (statusvalue) {
1984 if (list == beginav)
a0d0e21e 1985 croak("BEGIN failed--compilation aborted");
85e6fe83 1986 else
a0d0e21e 1987 croak("END failed--cleanup aborted");
85e6fe83 1988 }
85e6fe83
LW
1989 my_exit(statusvalue);
1990 /* NOTREACHED */
1991 return;
1992 case 3:
1993 if (!restartop) {
1994 fprintf(stderr, "panic: restartop\n");
a0d0e21e 1995 FREETMPS;
85e6fe83
LW
1996 break;
1997 }
a0d0e21e
LW
1998 Copy(oldtop, top_env, 1, jmp_buf);
1999 curcop = &compiling;
2000 curcop->cop_line = oldline;
2001 longjmp(top_env, 3);
8990e307 2002 }
93a17b20
LW
2003 }
2004
2005 Copy(oldtop, top_env, 1, jmp_buf);
2006}
2007