perl.c

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