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