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         if (restartav)
 556             calllist(restartav);
 557     }
 558
 559     /* do it */
 560
 561     if (restartop) {
 562         op = restartop;
 563         restartop = 0;
 564         runops();
 565     }
 566     else if (main_start) {
 567         op = main_start;
 568         runops();
 569     }
 570
 571     my_exit(0);
 572     return 0;
 573 }
 574
 575 void
 576 my_exit(status)
 577 U32 status;
 578 {
 579     register CONTEXT *cx;
 580     I32 gimme;
 581     SV **newsp;
 582
 583     statusvalue = FIXSTATUS(status);
 584     if (cxstack_ix >= 0) {
 585         if (cxstack_ix > 0)
 586             dounwind(0);
 587         POPBLOCK(cx,curpm);
 588         LEAVE;
 589     }
 590     Siglongjmp(top_env, 2);
 591 }
 592
 593 SV*
 594 perl_get_sv(name, create)
 595 char* name;
 596 I32 create;
 597 {
 598     GV* gv = gv_fetchpv(name, create, SVt_PV);
 599     if (gv)
 600         return GvSV(gv);
 601     return Nullsv;
 602 }
 603
 604 AV*
 605 perl_get_av(name, create)
 606 char* name;
 607 I32 create;
 608 {
 609     GV* gv = gv_fetchpv(name, create, SVt_PVAV);
 610     if (create)
 611         return GvAVn(gv);
 612     if (gv)
 613         return GvAV(gv);
 614     return Nullav;
 615 }
 616
 617 HV*
 618 perl_get_hv(name, create)
 619 char* name;
 620 I32 create;
 621 {
 622     GV* gv = gv_fetchpv(name, create, SVt_PVHV);
 623     if (create)
 624         return GvHVn(gv);
 625     if (gv)
 626         return GvHV(gv);
 627     return Nullhv;
 628 }
 629
 630 CV*
 631 perl_get_cv(name, create)
 632 char* name;
 633 I32 create;
 634 {
 635     GV* gv = gv_fetchpv(name, create, SVt_PVCV);
 636     if (create && !GvCV(gv))
 637         return newSUB(start_subparse(),
 638                       newSVOP(OP_CONST, 0, newSVpv(name,0)),
 639                       Nullop,
 640                       Nullop);
 641     if (gv)
 642         return GvCV(gv);
 643     return Nullcv;
 644 }
 645
 646 /* Be sure to refetch the stack pointer after calling these routines. */
 647
 648 I32
 649 perl_call_argv(subname, flags, argv)
 650 char *subname;
 651 I32 flags;              /* See G_* flags in cop.h */
 652 register char **argv;   /* null terminated arg list */
 653 {
 654     dSP;
 655
 656     PUSHMARK(sp);
 657     if (argv) {
 658         while (*argv) {
 659             XPUSHs(sv_2mortal(newSVpv(*argv,0)));
 660             argv++;
 661         }
 662         PUTBACK;
 663     }
 664     return perl_call_pv(subname, flags);
 665 }
 666
 667 I32
 668 perl_call_pv(subname, flags)
 669 char *subname;          /* name of the subroutine */
 670 I32 flags;              /* See G_* flags in cop.h */
 671 {
 672     return perl_call_sv((SV*)perl_get_cv(subname, TRUE), flags);
 673 }
 674
 675 I32
 676 perl_call_method(methname, flags)
 677 char *methname;         /* name of the subroutine */
 678 I32 flags;              /* See G_* flags in cop.h */
 679 {
 680     dSP;
 681     OP myop;
 682     if (!op)
 683         op = &myop;
 684     XPUSHs(sv_2mortal(newSVpv(methname,0)));
 685     PUTBACK;
 686     pp_method();
 687     return perl_call_sv(*stack_sp--, flags);
 688 }
 689
 690 /* May be called with any of a CV, a GV, or an SV containing the name. */
 691 I32
 692 perl_call_sv(sv, flags)
 693 SV* sv;
 694 I32 flags;              /* See G_* flags in cop.h */
 695 {
 696     LOGOP myop;         /* fake syntax tree node */
 697     SV** sp = stack_sp;
 698     I32 oldmark = TOPMARK;
 699     I32 retval;
 700     Sigjmp_buf oldtop;
 701     I32 oldscope;
 702
 703     if (flags & G_DISCARD) {
 704         ENTER;
 705         SAVETMPS;
 706     }
 707
 708     SAVESPTR(op);
 709     op = (OP*)&myop;
 710     Zero(op, 1, LOGOP);
 711     EXTEND(stack_sp, 1);
 712     *++stack_sp = sv;
 713     oldscope = scopestack_ix;
 714
 715     if (!(flags & G_NOARGS))
 716         myop.op_flags = OPf_STACKED;
 717     myop.op_next = Nullop;
 718     myop.op_flags |= OPf_KNOW;
 719     if (flags & G_ARRAY)
 720       myop.op_flags |= OPf_LIST;
 721
 722     if (flags & G_EVAL) {
 723         Copy(top_env, oldtop, 1, Sigjmp_buf);
 724
 725         cLOGOP->op_other = op;
 726         markstack_ptr--;
 727         /* we're trying to emulate pp_entertry() here */
 728         {
 729             register CONTEXT *cx;
 730             I32 gimme = GIMME;
 731
 732             ENTER;
 733             SAVETMPS;
 734
 735             push_return(op->op_next);
 736             PUSHBLOCK(cx, CXt_EVAL, stack_sp);
 737             PUSHEVAL(cx, 0, 0);
 738             eval_root = op;             /* Only needed so that goto works right. */
 739
 740             in_eval = 1;
 741             if (flags & G_KEEPERR)
 742                 in_eval |= 4;
 743             else
 744                 sv_setpv(GvSV(errgv),"");
 745         }
 746         markstack_ptr++;
 747
 748     restart:
 749         switch (Sigsetjmp(top_env,1)) {
 750         case 0:
 751             break;
 752         case 1:
 753 #ifdef VMS
 754             statusvalue = 255;  /* XXX I don't think we use 1 anymore. */
 755 #else
 756         statusvalue = 1;
 757 #endif
 758             /* FALL THROUGH */
 759         case 2:
 760             /* my_exit() was called */
 761             curstash = defstash;
 762             FREETMPS;
 763             Copy(oldtop, top_env, 1, Sigjmp_buf);
 764             if (statusvalue)
 765                 croak("Callback called exit");
 766             my_exit(statusvalue);
 767             /* NOTREACHED */
 768         case 3:
 769             if (restartop) {
 770                 op = restartop;
 771                 restartop = 0;
 772                 goto restart;
 773             }
 774             stack_sp = stack_base + oldmark;
 775             if (flags & G_ARRAY)
 776                 retval = 0;
 777             else {
 778                 retval = 1;
 779                 *++stack_sp = &sv_undef;
 780             }
 781             goto cleanup;
 782         }
 783     }
 784
 785     if (op == (OP*)&myop)
 786         op = pp_entersub();
 787     if (op)
 788         runops();
 789     retval = stack_sp - (stack_base + oldmark);
 790     if ((flags & G_EVAL) && !(flags & G_KEEPERR))
 791         sv_setpv(GvSV(errgv),"");
 792
 793   cleanup:
 794     if (flags & G_EVAL) {
 795         if (scopestack_ix > oldscope) {
 796             SV **newsp;
 797             PMOP *newpm;
 798             I32 gimme;
 799             register CONTEXT *cx;
 800             I32 optype;
 801
 802             POPBLOCK(cx,newpm);
 803             POPEVAL(cx);
 804             pop_return();
 805             curpm = newpm;
 806             LEAVE;
 807         }
 808         Copy(oldtop, top_env, 1, Sigjmp_buf);
 809     }
 810     if (flags & G_DISCARD) {
 811         stack_sp = stack_base + oldmark;
 812         retval = 0;
 813         FREETMPS;
 814         LEAVE;
 815     }
 816     return retval;
 817 }
 818
 819 /* Eval a string. */
 820
 821 I32
 822 perl_eval_sv(sv, flags)
 823 SV* sv;
 824 I32 flags;              /* See G_* flags in cop.h */
 825 {
 826     UNOP myop;          /* fake syntax tree node */
 827     SV** sp = stack_sp;
 828     I32 oldmark = sp - stack_base;
 829     I32 retval;
 830     Sigjmp_buf oldtop;
 831     I32 oldscope;
 832
 833     if (flags & G_DISCARD) {
 834         ENTER;
 835         SAVETMPS;
 836     }
 837
 838     SAVESPTR(op);
 839     op = (OP*)&myop;
 840     Zero(op, 1, UNOP);
 841     EXTEND(stack_sp, 1);
 842     *++stack_sp = sv;
 843     oldscope = scopestack_ix;
 844
 845     if (!(flags & G_NOARGS))
 846         myop.op_flags = OPf_STACKED;
 847     myop.op_next = Nullop;
 848     myop.op_flags |= OPf_KNOW;
 849     if (flags & G_ARRAY)
 850       myop.op_flags |= OPf_LIST;
 851
 852     Copy(top_env, oldtop, 1, Sigjmp_buf);
 853
 854 restart:
 855     switch (Sigsetjmp(top_env,1)) {
 856     case 0:
 857         break;
 858     case 1:
 859 #ifdef VMS
 860         statusvalue = 255;      /* XXX I don't think we use 1 anymore. */
 861 #else
 862     statusvalue = 1;
 863 #endif
 864         /* FALL THROUGH */
 865     case 2:
 866         /* my_exit() was called */
 867         curstash = defstash;
 868         FREETMPS;
 869         Copy(oldtop, top_env, 1, Sigjmp_buf);
 870         if (statusvalue)
 871             croak("Callback called exit");
 872         my_exit(statusvalue);
 873         /* NOTREACHED */
 874     case 3:
 875         if (restartop) {
 876             op = restartop;
 877             restartop = 0;
 878             goto restart;
 879         }
 880         stack_sp = stack_base + oldmark;
 881         if (flags & G_ARRAY)
 882             retval = 0;
 883         else {
 884             retval = 1;
 885             *++stack_sp = &sv_undef;
 886         }
 887         goto cleanup;
 888     }
 889
 890     if (op == (OP*)&myop)
 891         op = pp_entereval();
 892     if (op)
 893         runops();
 894     retval = stack_sp - (stack_base + oldmark);
 895     if ((flags & G_EVAL) && !(flags & G_KEEPERR))
 896         sv_setpv(GvSV(errgv),"");
 897
 898   cleanup:
 899     Copy(oldtop, top_env, 1, Sigjmp_buf);
 900     if (flags & G_DISCARD) {
 901         stack_sp = stack_base + oldmark;
 902         retval = 0;
 903         FREETMPS;
 904         LEAVE;
 905     }
 906     return retval;
 907 }
 908
 909 /* Require a module. */
 910
 911 void
 912 perl_require_pv(pv)
 913 char* pv;
 914 {
 915     SV* sv = sv_newmortal();
 916     sv_setpv(sv, "require '");
 917     sv_catpv(sv, pv);
 918     sv_catpv(sv, "'");
 919     perl_eval_sv(sv, G_DISCARD);
 920 }
 921
 922 void
 923 magicname(sym,name,namlen)
 924 char *sym;
 925 char *name;
 926 I32 namlen;
 927 {
 928     register GV *gv;
 929
 930     if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
 931         sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
 932 }
 933
 934 #if defined(DOSISH)
 935 #    define PERLLIB_SEP ';'
 936 #else
 937 #  if defined(VMS)
 938 #    define PERLLIB_SEP '|'
 939 #  else
 940 #    define PERLLIB_SEP ':'
 941 #  endif
 942 #endif
 943
 944 static void
 945 incpush(p)
 946 char *p;
 947 {
 948     char *s;
 949
 950     if (!p)
 951         return;
 952
 953     /* Break at all separators */
 954     while (*p) {
 955         /* First, skip any consecutive separators */
 956         while ( *p == PERLLIB_SEP ) {
 957             /* Uncomment the next line for PATH semantics */
 958             /* av_push(GvAVn(incgv), newSVpv(".", 1)); */
 959             p++;
 960         }
 961         if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
 962             av_push(GvAVn(incgv), newSVpv(p, (STRLEN)(s - p)));
 963             p = s + 1;
 964         } else {
 965             av_push(GvAVn(incgv), newSVpv(p, 0));
 966             break;
 967         }
 968     }
 969 }
 970
 971 static void
 972 usage(name)             /* XXX move this out into a module ? */
 973 char *name;
 974 {
 975     /* This message really ought to be max 23 lines.
 976      * Removed -h because the user already knows that opton. Others? */
 977     printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
 978     printf("\n  -0[octal]       specify record separator (\\0, if no argument)");
 979     printf("\n  -a              autosplit mode with -n or -p (splits $_ into @F)");
 980     printf("\n  -c              check syntax only (runs BEGIN and END blocks)");
 981     printf("\n  -d[:debugger]   run scripts under debugger");
 982     printf("\n  -D[number/list] set debugging flags (argument is a bit mask or flags)");
 983     printf("\n  -e 'command'    one line of script. Several -e's allowed. Omit [programfile].");
 984     printf("\n  -F/pattern/     split() pattern for autosplit (-a). The //'s are optional.");
 985     printf("\n  -i[extension]   edit <> files in place (make backup if extension supplied)");
 986     printf("\n  -Idirectory     specify @INC/#include directory (may be used more then once)");
 987     printf("\n  -l[octal]       enable line ending processing, specifies line teminator");
 988     printf("\n  -[mM][-]module.. executes `use/no module...' before executing your script.");
 989     printf("\n  -n              assume 'while (<>) { ... }' loop arround your script");
 990     printf("\n  -p              assume loop like -n but print line also like sed");
 991     printf("\n  -P              run script through C preprocessor before compilation");
 992 #ifdef OS2
 993     printf("\n  -R              enable REXX variable pool");
 994 #endif
 995     printf("\n  -s              enable some switch parsing for switches after script name");
 996     printf("\n  -S              look for the script using PATH environment variable");
 997     printf("\n  -T              turn on tainting checks");
 998     printf("\n  -u              dump core after parsing script");
 999     printf("\n  -U              allow unsafe operations");
1000     printf("\n  -v              print version number and patchlevel of perl");
1001     printf("\n  -V[:variable]   print perl configuration information");
1002     printf("\n  -w              TURN WARNINGS ON FOR COMPILATION OF YOUR SCRIPT.");
1003     printf("\n  -x[directory]   strip off text before #!perl line and perhaps cd to directory\n");
1004 }
1005
1006 /* This routine handles any switches that can be given during run */
1007
1008 char *
1009 moreswitches(s)
1010 char *s;
1011 {
1012     I32 numlen;
1013     U32 rschar;
1014
1015     switch (*s) {
1016     case '0':
1017         rschar = scan_oct(s, 4, &numlen);
1018         SvREFCNT_dec(nrs);
1019         if (rschar & ~((U8)~0))
1020             nrs = &sv_undef;
1021         else if (!rschar && numlen >= 2)
1022             nrs = newSVpv("", 0);
1023         else {
1024             char ch = rschar;
1025             nrs = newSVpv(&ch, 1);
1026         }
1027         return s + numlen;
1028     case 'F':
1029         minus_F = TRUE;
1030         splitstr = savepv(s + 1);
1031         s += strlen(s);
1032         return s;
1033     case 'a':
1034         minus_a = TRUE;
1035         s++;
1036         return s;
1037     case 'c':
1038         minus_c = TRUE;
1039         s++;
1040         return s;
1041     case 'd':
1042         taint_not("-d");
1043         s++;
1044         if (*s == ':' || *s == '=')  {
1045             sprintf(buf, "use Devel::%s;", ++s);
1046             s += strlen(s);
1047             my_setenv("PERL5DB",buf);
1048         }
1049         if (!perldb) {
1050             perldb = TRUE;
1051             init_debugger();
1052         }
1053         return s;
1054     case 'D':
1055 #ifdef DEBUGGING
1056         taint_not("-D");
1057         if (isALPHA(s[1])) {
1058             static char debopts[] = "psltocPmfrxuLHXD";
1059             char *d;
1060
1061             for (s++; *s && (d = strchr(debopts,*s)); s++)
1062                 debug |= 1 << (d - debopts);
1063         }
1064         else {
1065             debug = atoi(s+1);
1066             for (s++; isDIGIT(*s); s++) ;
1067         }
1068         debug |= 0x80000000;
1069 #else
1070         warn("Recompile perl with -DDEBUGGING to use -D switch\n");
1071         for (s++; isALNUM(*s); s++) ;
1072 #endif
1073         /*SUPPRESS 530*/
1074         return s;
1075     case 'h':
1076         usage(origargv[0]);
1077         exit(0);
1078     case 'i':
1079         if (inplace)
1080             Safefree(inplace);
1081         inplace = savepv(s+1);
1082         /*SUPPRESS 530*/
1083         for (s = inplace; *s && !isSPACE(*s); s++) ;
1084         *s = '\0';
1085         break;
1086     case 'I':
1087         taint_not("-I");
1088         if (*++s) {
1089             char *e;
1090             for (e = s; *e && !isSPACE(*e); e++) ;
1091             av_push(GvAVn(incgv),newSVpv(s,e-s));
1092             if (*e)
1093                 return e;
1094         }
1095         else
1096             croak("No space allowed after -I");
1097         break;
1098     case 'l':
1099         minus_l = TRUE;
1100         s++;
1101         if (ors)
1102             Safefree(ors);
1103         if (isDIGIT(*s)) {
1104             ors = savepv("\n");
1105             orslen = 1;
1106             *ors = scan_oct(s, 3 + (*s == '0'), &numlen);
1107             s += numlen;
1108         }
1109         else {
1110             if (RsPARA(nrs)) {
1111                 ors = savepvn("\n\n", 2);
1112                 orslen = 2;
1113             }
1114             else
1115                 ors = SvPV(nrs, orslen);
1116         }
1117         return s;
1118     case 'M':
1119         taint_not("-M");        /* XXX ? */
1120         /* FALL THROUGH */
1121     case 'm':
1122         taint_not("-m");        /* XXX ? */
1123         if (*++s) {
1124             char *start;
1125             char *use = "use ";
1126             /* -M-foo == 'no foo'       */
1127             if (*s == '-') { use = "no "; ++s; }
1128             Sv = newSVpv(use,0);
1129             start = s;
1130             /* We allow -M'Module qw(Foo Bar)'  */
1131             while(isALNUM(*s) || *s==':') ++s;
1132             if (*s != '=') {
1133                 sv_catpv(Sv, start);
1134                 if (*(start-1) == 'm') {
1135                     if (*s != '\0')
1136                         croak("Can't use '%c' after -mname", *s);
1137                     sv_catpv( Sv, " ()");
1138                 }
1139             } else {
1140                 sv_catpvn(Sv, start, s-start);
1141                 sv_catpv(Sv, " split(/,/,q{");
1142                 sv_catpv(Sv, ++s);
1143                 sv_catpv(Sv,    "})");
1144             }
1145             s += strlen(s);
1146             if (preambleav == NULL)
1147                 preambleav = newAV();
1148             av_push(preambleav, Sv);
1149         }
1150         else
1151             croak("No space allowed after -%c", *(s-1));
1152         return s;
1153     case 'n':
1154         minus_n = TRUE;
1155         s++;
1156         return s;
1157     case 'p':
1158         minus_p = TRUE;
1159         s++;
1160         return s;
1161     case 's':
1162         taint_not("-s");
1163         doswitches = TRUE;
1164         s++;
1165         return s;
1166     case 'T':
1167         tainting = TRUE;
1168         s++;
1169         return s;
1170     case 'u':
1171         do_undump = TRUE;
1172         s++;
1173         return s;
1174     case 'U':
1175         unsafe = TRUE;
1176         s++;
1177         return s;
1178     case 'v':
1179 #if defined(SUBVERSION) && SUBVERSION > 0
1180         printf("\nThis is perl, version 5.%03d_%02d", PATCHLEVEL, SUBVERSION);
1181 #else
1182         printf("\nThis is perl, version %s",patchlevel);
1183 #endif
1184
1185 #if defined(DEBUGGING) || defined(EMBED) || defined(MULTIPLICITY)
1186         fputs(" with", stdout);
1187 #ifdef DEBUGGING
1188         fputs(" DEBUGGING", stdout);
1189 #endif
1190 #ifdef EMBED
1191         fputs(" EMBED", stdout);
1192 #endif
1193 #ifdef MULTIPLICITY
1194         fputs(" MULTIPLICITY", stdout);
1195 #endif
1196 #endif
1197
1198 #if defined(LOCAL_PATCH_COUNT)
1199     if (LOCAL_PATCH_COUNT > 0)
1200     {   int i;
1201         fputs("\n\tLocally applied patches:\n", stdout);
1202         for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
1203                 if (Ilocalpatches[i])
1204                         fprintf(stdout, "\t  %s\n", Ilocalpatches[i]);
1205         }
1206     }
1207 #endif
1208     printf("\n\tbuilt under %s",OSNAME);
1209 #ifdef __DATE__
1210 #  ifdef __TIME__
1211         printf(" at %s %s",__DATE__,__TIME__);
1212 #  else
1213         printf(" on %s",__DATE__);
1214 #  endif
1215 #endif
1216         fputs("\n\t+ suidperl security patch", stdout);
1217         fputs("\n\nCopyright 1987-1996, Larry Wall\n",stdout);
1218 #ifdef MSDOS
1219         fputs("MS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n",
1220         stdout);
1221 #endif
1222 #ifdef OS2
1223         fputs("OS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
1224             "Version 5 port Copyright (c) 1994-1995, Andreas Kaiser\n", stdout);
1225 #endif
1226 #ifdef atarist
1227         fputs("atariST series port, ++jrb  bammi@cadence.com\n", stdout);
1228 #endif
1229         fputs("\n\
1230 Perl may be copied only under the terms of either the Artistic License or the\n\
1231 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n",stdout);
1232 #ifdef MSDOS
1233         usage(origargv[0]);
1234 #endif
1235         exit(0);
1236     case 'w':
1237         dowarn = TRUE;
1238         s++;
1239         return s;
1240     case '*':
1241     case ' ':
1242         if (s[1] == '-')        /* Additional switches on #! line. */
1243             return s+2;
1244         break;
1245     case '-':
1246     case 0:
1247     case '\n':
1248     case '\t':
1249         break;
1250     case 'P':
1251         if (preprocess)
1252             return s+1;
1253         /* FALL THROUGH */
1254     default:
1255         croak("Can't emulate -%.1s on #! line",s);
1256     }
1257     return Nullch;
1258 }
1259
1260 /* compliments of Tom Christiansen */
1261
1262 /* unexec() can be found in the Gnu emacs distribution */
1263
1264 void
1265 my_unexec()
1266 {
1267 #ifdef UNEXEC
1268     int    status;
1269     extern int etext;
1270
1271     sprintf (buf, "%s.perldump", origfilename);
1272     sprintf (tokenbuf, "%s/perl", BIN);
1273
1274     status = unexec(buf, tokenbuf, &etext, sbrk(0), 0);
1275     if (status)
1276         fprintf(stderr, "unexec of %s into %s failed!\n", tokenbuf, buf);
1277     exit(status);
1278 #else
1279 #  ifdef VMS
1280 #    include <lib$routines.h>
1281      lib$signal(SS$_DEBUG);  /* ssdef.h #included from vmsish.h */
1282 #else
1283     ABORT();            /* for use with undump */
1284 #endif
1285 #endif
1286 }
1287
1288 static void
1289 init_main_stash()
1290 {
1291     GV *gv;
1292     curstash = defstash = newHV();
1293     curstname = newSVpv("main",4);
1294     gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
1295     SvREFCNT_dec(GvHV(gv));
1296     GvHV(gv) = (HV*)SvREFCNT_inc(defstash);
1297     SvREADONLY_on(gv);
1298     HvNAME(defstash) = savepv("main");
1299     incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
1300     GvMULTI_on(incgv);
1301     defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
1302     errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
1303     GvMULTI_on(errgv);
1304     curstash = defstash;
1305     compiling.cop_stash = defstash;
1306     debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
1307     /* We must init $/ before switches are processed. */
1308     sv_setpvn(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), "\n", 1);
1309 }
1310
1311 #ifdef CAN_PROTOTYPE
1312 static void
1313 open_script(char *scriptname, bool dosearch, SV *sv)
1314 #else
1315 static void
1316 open_script(scriptname,dosearch,sv)
1317 char *scriptname;
1318 bool dosearch;
1319 SV *sv;
1320 #endif
1321 {
1322     char *xfound = Nullch;
1323     char *xfailed = Nullch;
1324     register char *s;
1325     I32 len;
1326     int retval;
1327 #if defined(DOSISH) && !defined(OS2) && !defined(atarist)
1328 #define SEARCH_EXTS ".bat", ".cmd", NULL
1329 #endif
1330 #ifdef VMS
1331 #  define SEARCH_EXTS ".pl", ".com", NULL
1332 #endif
1333     /* additional extensions to try in each dir if scriptname not found */
1334 #ifdef SEARCH_EXTS
1335     char *ext[] = { SEARCH_EXTS };
1336     int extidx = (strchr(scriptname,'.')) ? -1 : 0; /* has ext already */
1337 #endif
1338
1339 #ifdef VMS
1340     if (dosearch && !strpbrk(scriptname,":[</") && (my_getenv("DCL$PATH"))) {
1341         int idx = 0;
1342
1343         while (my_trnlnm("DCL$PATH",tokenbuf,idx++)) {
1344             strcat(tokenbuf,scriptname);
1345 #else  /* !VMS */
1346     if (dosearch && !strchr(scriptname, '/') && (s = getenv("PATH"))) {
1347
1348         bufend = s + strlen(s);
1349         while (*s) {
1350 #ifndef DOSISH
1351             s = cpytill(tokenbuf,s,bufend,':',&len);
1352 #else
1353 #ifdef atarist
1354             for (len = 0; *s && *s != ',' && *s != ';'; tokenbuf[len++] = *s++);
1355             tokenbuf[len] = '\0';
1356 #else
1357             for (len = 0; *s && *s != ';'; tokenbuf[len++] = *s++);
1358             tokenbuf[len] = '\0';
1359 #endif
1360 #endif
1361             if (*s)
1362                 s++;
1363 #ifndef DOSISH
1364             if (len && tokenbuf[len-1] != '/')
1365 #else
1366 #ifdef atarist
1367             if (len && ((tokenbuf[len-1] != '\\') && (tokenbuf[len-1] != '/')))
1368 #else
1369             if (len && tokenbuf[len-1] != '\\')
1370 #endif
1371 #endif
1372                 (void)strcat(tokenbuf+len,"/");
1373             (void)strcat(tokenbuf+len,scriptname);
1374 #endif  /* !VMS */
1375
1376 #ifdef SEARCH_EXTS
1377             len = strlen(tokenbuf);
1378             if (extidx > 0)     /* reset after previous loop */
1379                 extidx = 0;
1380             do {
1381 #endif
1382                 DEBUG_p(fprintf(stderr,"Looking for %s\n",tokenbuf));
1383                 retval = Stat(tokenbuf,&statbuf);
1384 #ifdef SEARCH_EXTS
1385             } while (  retval < 0               /* not there */
1386                     && extidx>=0 && ext[extidx] /* try an extension? */
1387                     && strcpy(tokenbuf+len, ext[extidx++])
1388                 );
1389 #endif
1390             if (retval < 0)
1391                 continue;
1392             if (S_ISREG(statbuf.st_mode)
1393              && cando(S_IRUSR,TRUE,&statbuf) && cando(S_IXUSR,TRUE,&statbuf)) {
1394                 xfound = tokenbuf;              /* bingo! */
1395                 break;
1396             }
1397             if (!xfailed)
1398                 xfailed = savepv(tokenbuf);
1399         }
1400         if (!xfound)
1401             croak("Can't execute %s", xfailed ? xfailed : scriptname );
1402         if (xfailed)
1403             Safefree(xfailed);
1404         scriptname = xfound;
1405     }
1406
1407     if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
1408         char *s = scriptname + 8;
1409         fdscript = atoi(s);
1410         while (isDIGIT(*s))
1411             s++;
1412         if (*s)
1413             scriptname = s + 1;
1414     }
1415     else
1416         fdscript = -1;
1417     origfilename = savepv(e_tmpname ? "-e" : scriptname);
1418     curcop->cop_filegv = gv_fetchfile(origfilename);
1419     if (strEQ(origfilename,"-"))
1420         scriptname = "";
1421     if (fdscript >= 0) {
1422         rsfp = fdopen(fdscript,"r");
1423 #if defined(HAS_FCNTL) && defined(F_SETFD)
1424         fcntl(fileno(rsfp),F_SETFD,1);  /* ensure close-on-exec */
1425 #endif
1426     }
1427     else if (preprocess) {
1428         char *cpp = CPPSTDIN;
1429
1430         if (strEQ(cpp,"cppstdin"))
1431             sprintf(tokenbuf, "%s/%s", SCRIPTDIR, cpp);
1432         else
1433             sprintf(tokenbuf, "%s", cpp);
1434         sv_catpv(sv,"-I");
1435         sv_catpv(sv,PRIVLIB_EXP);
1436 #ifdef MSDOS
1437         (void)sprintf(buf, "\
1438 sed %s -e \"/^[^#]/b\" \
1439  -e \"/^#[      ]*include[      ]/b\" \
1440  -e \"/^#[      ]*define[       ]/b\" \
1441  -e \"/^#[      ]*if[   ]/b\" \
1442  -e \"/^#[      ]*ifdef[        ]/b\" \
1443  -e \"/^#[      ]*ifndef[       ]/b\" \
1444  -e \"/^#[      ]*else/b\" \
1445  -e \"/^#[      ]*elif[         ]/b\" \
1446  -e \"/^#[      ]*undef[        ]/b\" \
1447  -e \"/^#[      ]*endif/b\" \
1448  -e \"s/^#.*//\" \
1449  %s | %s -C %s %s",
1450           (doextract ? "-e \"1,/^#/d\n\"" : ""),
1451 #else
1452         (void)sprintf(buf, "\
1453 %s %s -e '/^[^#]/b' \
1454  -e '/^#[       ]*include[      ]/b' \
1455  -e '/^#[       ]*define[       ]/b' \
1456  -e '/^#[       ]*if[   ]/b' \
1457  -e '/^#[       ]*ifdef[        ]/b' \
1458  -e '/^#[       ]*ifndef[       ]/b' \
1459  -e '/^#[       ]*else/b' \
1460  -e '/^#[       ]*elif[         ]/b' \
1461  -e '/^#[       ]*undef[        ]/b' \
1462  -e '/^#[       ]*endif/b' \
1463  -e 's/^[       ]*#.*//' \
1464  %s | %s -C %s %s",
1465 #ifdef LOC_SED
1466           LOC_SED,
1467 #else
1468           "sed",
1469 #endif
1470           (doextract ? "-e '1,/^#/d\n'" : ""),
1471 #endif
1472           scriptname, tokenbuf, SvPV(sv, na), CPPMINUS);
1473         doextract = FALSE;
1474 #ifdef IAMSUID                          /* actually, this is caught earlier */
1475         if (euid != uid && !euid) {     /* if running suidperl */
1476 #ifdef HAS_SETEUID
1477             (void)seteuid(uid);         /* musn't stay setuid root */
1478 #else
1479 #ifdef HAS_SETREUID
1480             (void)setreuid((Uid_t)-1, uid);
1481 #else
1482 #ifdef HAS_SETRESUID
1483             (void)setresuid((Uid_t)-1, uid, (Uid_t)-1);
1484 #else
1485             setuid(uid);
1486 #endif
1487 #endif
1488 #endif
1489             if (geteuid() != uid)
1490                 croak("Can't do seteuid!\n");
1491         }
1492 #endif /* IAMSUID */
1493         rsfp = my_popen(buf,"r");
1494     }
1495     else if (!*scriptname) {
1496         taint_not("program input from stdin");
1497         rsfp = stdin;
1498     }
1499     else {
1500         rsfp = fopen(scriptname,"r");
1501 #if defined(HAS_FCNTL) && defined(F_SETFD)
1502         fcntl(fileno(rsfp),F_SETFD,1);  /* ensure close-on-exec */
1503 #endif
1504     }
1505     if ((FILE*)rsfp == Nullfp) {
1506 #ifdef DOSUID
1507 #ifndef IAMSUID         /* in case script is not readable before setuid */
1508         if (euid && Stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
1509           statbuf.st_mode & (S_ISUID|S_ISGID)) {
1510             (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
1511             execv(buf, origargv);       /* try again */
1512             croak("Can't do setuid\n");
1513         }
1514 #endif
1515 #endif
1516         croak("Can't open perl script \"%s\": %s\n",
1517           SvPVX(GvSV(curcop->cop_filegv)), Strerror(errno));
1518     }
1519 }
1520
1521 static void
1522 validate_suid(validarg, scriptname)
1523 char *validarg;
1524 char *scriptname;
1525 {
1526     int which;
1527
1528     /* do we need to emulate setuid on scripts? */
1529
1530     /* This code is for those BSD systems that have setuid #! scripts disabled
1531      * in the kernel because of a security problem.  Merely defining DOSUID
1532      * in perl will not fix that problem, but if you have disabled setuid
1533      * scripts in the kernel, this will attempt to emulate setuid and setgid
1534      * on scripts that have those now-otherwise-useless bits set.  The setuid
1535      * root version must be called suidperl or sperlN.NNN.  If regular perl
1536      * discovers that it has opened a setuid script, it calls suidperl with
1537      * the same argv that it had.  If suidperl finds that the script it has
1538      * just opened is NOT setuid root, it sets the effective uid back to the
1539      * uid.  We don't just make perl setuid root because that loses the
1540      * effective uid we had before invoking perl, if it was different from the
1541      * uid.
1542      *
1543      * DOSUID must be defined in both perl and suidperl, and IAMSUID must
1544      * be defined in suidperl only.  suidperl must be setuid root.  The
1545      * Configure script will set this up for you if you want it.
1546      */
1547
1548 #ifdef DOSUID
1549     char *s;
1550
1551     if (Fstat(fileno(rsfp),&statbuf) < 0)       /* normal stat is insecure */
1552         croak("Can't stat script \"%s\"",origfilename);
1553     if (fdscript < 0 && statbuf.st_mode & (S_ISUID|S_ISGID)) {
1554         I32 len;
1555
1556 #ifdef IAMSUID
1557 #ifndef HAS_SETREUID
1558         /* On this access check to make sure the directories are readable,
1559          * there is actually a small window that the user could use to make
1560          * filename point to an accessible directory.  So there is a faint
1561          * chance that someone could execute a setuid script down in a
1562          * non-accessible directory.  I don't know what to do about that.
1563          * But I don't think it's too important.  The manual lies when
1564          * it says access() is useful in setuid programs.
1565          */
1566         if (access(SvPVX(GvSV(curcop->cop_filegv)),1))  /*double check*/
1567             croak("Permission denied");
1568 #else
1569         /* If we can swap euid and uid, then we can determine access rights
1570          * with a simple stat of the file, and then compare device and
1571          * inode to make sure we did stat() on the same file we opened.
1572          * Then we just have to make sure he or she can execute it.
1573          */
1574         {
1575             struct stat tmpstatbuf;
1576
1577             if (
1578 #ifdef HAS_SETREUID
1579                 setreuid(euid,uid) < 0
1580 #else
1581 # if HAS_SETRESUID
1582                 setresuid(euid,uid,(Uid_t)-1) < 0
1583 # endif
1584 #endif
1585                 || getuid() != euid || geteuid() != uid)
1586                 croak("Can't swap uid and euid");       /* really paranoid */
1587             if (Stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0)
1588                 croak("Permission denied");     /* testing full pathname here */
1589             if (tmpstatbuf.st_dev != statbuf.st_dev ||
1590                 tmpstatbuf.st_ino != statbuf.st_ino) {
1591                 (void)fclose(rsfp);
1592                 if (rsfp = my_popen("/bin/mail root","w")) {    /* heh, heh */
1593                     fprintf(rsfp,
1594 "User %d tried to run dev %d ino %d in place of dev %d ino %d!\n\
1595 (Filename of set-id script was %s, uid %d gid %d.)\n\nSincerely,\nperl\n",
1596                         uid,tmpstatbuf.st_dev, tmpstatbuf.st_ino,
1597                         statbuf.st_dev, statbuf.st_ino,
1598                         SvPVX(GvSV(curcop->cop_filegv)),
1599                         statbuf.st_uid, statbuf.st_gid);
1600                     (void)my_pclose(rsfp);
1601                 }
1602                 croak("Permission denied\n");
1603             }
1604             if (
1605 #ifdef HAS_SETREUID
1606               setreuid(uid,euid) < 0
1607 #else
1608 # if defined(HAS_SETRESUID)
1609               setresuid(uid,euid,(Uid_t)-1) < 0
1610 # endif
1611 #endif
1612               || getuid() != uid || geteuid() != euid)
1613                 croak("Can't reswap uid and euid");
1614             if (!cando(S_IXUSR,FALSE,&statbuf))         /* can real uid exec? */
1615                 croak("Permission denied\n");
1616         }
1617 #endif /* HAS_SETREUID */
1618 #endif /* IAMSUID */
1619
1620         if (!S_ISREG(statbuf.st_mode))
1621             croak("Permission denied");
1622         if (statbuf.st_mode & S_IWOTH)
1623             croak("Setuid/gid script is writable by world");
1624         doswitches = FALSE;             /* -s is insecure in suid */
1625         curcop->cop_line++;
1626         if (fgets(tokenbuf,sizeof tokenbuf, rsfp) == Nullch ||
1627           strnNE(tokenbuf,"#!",2) )     /* required even on Sys V */
1628             croak("No #! line");
1629         s = tokenbuf+2;
1630         if (*s == ' ') s++;
1631         while (!isSPACE(*s)) s++;
1632         if (strnNE(s-4,"perl",4) && strnNE(s-9,"perl",4))  /* sanity check */
1633             croak("Not a perl script");
1634         while (*s == ' ' || *s == '\t') s++;
1635         /*
1636          * #! arg must be what we saw above.  They can invoke it by
1637          * mentioning suidperl explicitly, but they may not add any strange
1638          * arguments beyond what #! says if they do invoke suidperl that way.
1639          */
1640         len = strlen(validarg);
1641         if (strEQ(validarg," PHOOEY ") ||
1642             strnNE(s,validarg,len) || !isSPACE(s[len]))
1643             croak("Args must match #! line");
1644
1645 #ifndef IAMSUID
1646         if (euid != uid && (statbuf.st_mode & S_ISUID) &&
1647             euid == statbuf.st_uid)
1648             if (!do_undump)
1649                 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
1650 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
1651 #endif /* IAMSUID */
1652
1653         if (euid) {     /* oops, we're not the setuid root perl */
1654             (void)fclose(rsfp);
1655 #ifndef IAMSUID
1656             (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
1657             execv(buf, origargv);       /* try again */
1658 #endif
1659             croak("Can't do setuid\n");
1660         }
1661
1662         if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) {
1663 #ifdef HAS_SETEGID
1664             (void)setegid(statbuf.st_gid);
1665 #else
1666 #ifdef HAS_SETREGID
1667            (void)setregid((Gid_t)-1,statbuf.st_gid);
1668 #else
1669 #ifdef HAS_SETRESGID
1670            (void)setresgid((Gid_t)-1,statbuf.st_gid,(Gid_t)-1);
1671 #else
1672             setgid(statbuf.st_gid);
1673 #endif
1674 #endif
1675 #endif
1676             if (getegid() != statbuf.st_gid)
1677                 croak("Can't do setegid!\n");
1678         }
1679         if (statbuf.st_mode & S_ISUID) {
1680             if (statbuf.st_uid != euid)
1681 #ifdef HAS_SETEUID
1682                 (void)seteuid(statbuf.st_uid);  /* all that for this */
1683 #else
1684 #ifdef HAS_SETREUID
1685                 (void)setreuid((Uid_t)-1,statbuf.st_uid);
1686 #else
1687 #ifdef HAS_SETRESUID
1688                 (void)setresuid((Uid_t)-1,statbuf.st_uid,(Uid_t)-1);
1689 #else
1690                 setuid(statbuf.st_uid);
1691 #endif
1692 #endif
1693 #endif
1694             if (geteuid() != statbuf.st_uid)
1695                 croak("Can't do seteuid!\n");
1696         }
1697         else if (uid) {                 /* oops, mustn't run as root */
1698 #ifdef HAS_SETEUID
1699           (void)seteuid((Uid_t)uid);
1700 #else
1701 #ifdef HAS_SETREUID
1702           (void)setreuid((Uid_t)-1,(Uid_t)uid);
1703 #else
1704 #ifdef HAS_SETRESUID
1705           (void)setresuid((Uid_t)-1,(Uid_t)uid,(Uid_t)-1);
1706 #else
1707           setuid((Uid_t)uid);
1708 #endif
1709 #endif
1710 #endif
1711             if (geteuid() != uid)
1712                 croak("Can't do seteuid!\n");
1713         }
1714         init_ids();
1715         if (!cando(S_IXUSR,TRUE,&statbuf))
1716             croak("Permission denied\n");       /* they can't do this */
1717     }
1718 #ifdef IAMSUID
1719     else if (preprocess)
1720         croak("-P not allowed for setuid/setgid script\n");
1721     else if (fdscript >= 0)
1722         croak("fd script not allowed in suidperl\n");
1723     else
1724         croak("Script is not setuid/setgid in suidperl\n");
1725
1726     /* We absolutely must clear out any saved ids here, so we */
1727     /* exec the real perl, substituting fd script for scriptname. */
1728     /* (We pass script name as "subdir" of fd, which perl will grok.) */
1729     rewind(rsfp);
1730     for (which = 1; origargv[which] && origargv[which] != scriptname; which++) ;
1731     if (!origargv[which])
1732         croak("Permission denied");
1733     (void)sprintf(buf, "/dev/fd/%d/%.127s", fileno(rsfp), origargv[which]);
1734     origargv[which] = buf;
1735
1736 #if defined(HAS_FCNTL) && defined(F_SETFD)
1737     fcntl(fileno(rsfp),F_SETFD,0);      /* ensure no close-on-exec */
1738 #endif
1739
1740     (void)sprintf(tokenbuf, "%s/perl%s", BIN, patchlevel);
1741     execv(tokenbuf, origargv);  /* try again */
1742     croak("Can't do setuid\n");
1743 #endif /* IAMSUID */
1744 #else /* !DOSUID */
1745     if (euid != uid || egid != gid) {   /* (suidperl doesn't exist, in fact) */
1746 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
1747         Fstat(fileno(rsfp),&statbuf);   /* may be either wrapped or real suid */
1748         if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
1749             ||
1750             (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
1751            )
1752             if (!do_undump)
1753                 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
1754 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
1755 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
1756         /* not set-id, must be wrapped */
1757     }
1758 #endif /* DOSUID */
1759 }
1760
1761 static void
1762 find_beginning()
1763 {
1764     register char *s;
1765
1766     /* skip forward in input to the real script? */
1767
1768     taint_not("-x");
1769     while (doextract) {
1770         if ((s = sv_gets(linestr, rsfp, 0)) == Nullch)
1771             croak("No Perl script found in input\n");
1772         if (*s == '#' && s[1] == '!' && instr(s,"perl")) {
1773             ungetc('\n',rsfp);          /* to keep line count right */
1774             doextract = FALSE;
1775             if (s = instr(s,"perl -")) {
1776                 s += 6;
1777                 /*SUPPRESS 530*/
1778                 while (s = moreswitches(s)) ;
1779             }
1780             if (cddir && chdir(cddir) < 0)
1781                 croak("Can't chdir to %s",cddir);
1782         }
1783     }
1784 }
1785
1786 static void
1787 init_ids()
1788 {
1789     uid = (int)getuid();
1790     euid = (int)geteuid();
1791     gid = (int)getgid();
1792     egid = (int)getegid();
1793 #ifdef VMS
1794     uid |= gid << 16;
1795     euid |= egid << 16;
1796 #endif
1797     tainting |= (uid && (euid != uid || egid != gid));
1798 }
1799
1800 static void
1801 init_debugger()
1802 {
1803     curstash = debstash;
1804     dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
1805     AvREAL_off(dbargs);
1806     DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
1807     DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
1808     DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
1809     DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
1810     sv_setiv(DBsingle, 0);
1811     DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
1812     sv_setiv(DBtrace, 0);
1813     DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
1814     sv_setiv(DBsignal, 0);
1815     curstash = defstash;
1816 }
1817
1818 static void
1819 init_stacks()
1820 {
1821     stack = newAV();
1822     mainstack = stack;                  /* remember in case we switch stacks */
1823     AvREAL_off(stack);                  /* not a real array */
1824     av_extend(stack,127);
1825
1826     stack_base = AvARRAY(stack);
1827     stack_sp = stack_base;
1828     stack_max = stack_base + 127;
1829
1830     New(54,markstack,64,I32);
1831     markstack_ptr = markstack;
1832     markstack_max = markstack + 64;
1833
1834     New(54,scopestack,32,I32);
1835     scopestack_ix = 0;
1836     scopestack_max = 32;
1837
1838     New(54,savestack,128,ANY);
1839     savestack_ix = 0;
1840     savestack_max = 128;
1841
1842     New(54,retstack,16,OP*);
1843     retstack_ix = 0;
1844     retstack_max = 16;
1845
1846     cxstack_max = 8192 / sizeof(CONTEXT) - 2;   /* Use most of 8K. */
1847     New(50,cxstack,cxstack_max + 1,CONTEXT);
1848     cxstack_ix  = -1;
1849
1850     New(50,tmps_stack,128,SV*);
1851     tmps_ix = -1;
1852     tmps_max = 128;
1853
1854     DEBUG( {
1855         New(51,debname,128,char);
1856         New(52,debdelim,128,char);
1857     } )
1858 }
1859
1860 static FILE *tmpfp;  /* moved outside init_lexer() because of UNICOS bug */
1861 static void
1862 init_lexer()
1863 {
1864     tmpfp = rsfp;
1865
1866     lex_start(linestr);
1867     rsfp = tmpfp;
1868     subname = newSVpv("main",4);
1869 }
1870
1871 static void
1872 init_predump_symbols()
1873 {
1874     GV *tmpgv;
1875     GV *othergv;
1876
1877     sv_setpvn(GvSV(gv_fetchpv("\"", TRUE, SVt_PV)), " ", 1);
1878
1879     stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
1880     GvMULTI_on(stdingv);
1881     IoIFP(GvIOp(stdingv)) = stdin;
1882     tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
1883     GvMULTI_on(tmpgv);
1884     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(stdingv));
1885
1886     tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
1887     GvMULTI_on(tmpgv);
1888     IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = stdout;
1889     setdefout(tmpgv);
1890     tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
1891     GvMULTI_on(tmpgv);
1892     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(defoutgv));
1893
1894     othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
1895     GvMULTI_on(othergv);
1896     IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = stderr;
1897     tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
1898     GvMULTI_on(tmpgv);
1899     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv));
1900
1901     statname = NEWSV(66,0);             /* last filename we did stat on */
1902
1903     osname = savepv(OSNAME);
1904 }
1905
1906 static void
1907 init_postdump_symbols(argc,argv,env)
1908 register int argc;
1909 register char **argv;
1910 register char **env;
1911 {
1912     char *s;
1913     SV *sv;
1914     GV* tmpgv;
1915
1916     argc--,argv++;      /* skip name of script */
1917     if (doswitches) {
1918         for (; argc > 0 && **argv == '-'; argc--,argv++) {
1919             if (!argv[0][1])
1920                 break;
1921             if (argv[0][1] == '-') {
1922                 argc--,argv++;
1923                 break;
1924             }
1925             if (s = strchr(argv[0], '=')) {
1926                 *s++ = '\0';
1927                 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
1928             }
1929             else
1930                 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),1);
1931         }
1932     }
1933     toptarget = NEWSV(0,0);
1934     sv_upgrade(toptarget, SVt_PVFM);
1935     sv_setpvn(toptarget, "", 0);
1936     bodytarget = NEWSV(0,0);
1937     sv_upgrade(bodytarget, SVt_PVFM);
1938     sv_setpvn(bodytarget, "", 0);
1939     formtarget = bodytarget;
1940
1941     tainted = 1;
1942     if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
1943         sv_setpv(GvSV(tmpgv),origfilename);
1944         magicname("0", "0", 1);
1945     }
1946     if (tmpgv = gv_fetchpv("\024",TRUE, SVt_PV))
1947         time(&basetime);
1948     if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
1949         sv_setpv(GvSV(tmpgv),origargv[0]);
1950     if (argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
1951         GvMULTI_on(argvgv);
1952         (void)gv_AVadd(argvgv);
1953         av_clear(GvAVn(argvgv));
1954         for (; argc > 0; argc--,argv++) {
1955             av_push(GvAVn(argvgv),newSVpv(argv[0],0));
1956         }
1957     }
1958     if (envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
1959         HV *hv;
1960         GvMULTI_on(envgv);
1961         hv = GvHVn(envgv);
1962         hv_clear(hv);
1963 #ifndef VMS  /* VMS doesn't have environ array */
1964         /* Note that if the supplied env parameter is actually a copy
1965            of the global environ then it may now point to free'd memory
1966            if the environment has been modified since. To avoid this
1967            problem we treat env==NULL as meaning 'use the default'
1968         */
1969         if (!env)
1970             env = environ;
1971         if (env != environ) {
1972             environ[0] = Nullch;
1973             hv_magic(hv, envgv, 'E');
1974         }
1975         for (; *env; env++) {
1976             if (!(s = strchr(*env,'=')))
1977                 continue;
1978             *s++ = '\0';
1979             sv = newSVpv(s--,0);
1980             sv_magic(sv, sv, 'e', *env, s - *env);
1981             (void)hv_store(hv, *env, s - *env, sv, 0);
1982             *s = '=';
1983         }
1984 #endif
1985 #ifdef DYNAMIC_ENV_FETCH
1986         HvNAME(hv) = savepv(ENV_HV_NAME);
1987 #endif
1988         hv_magic(hv, envgv, 'E');
1989     }
1990     tainted = 0;
1991     if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
1992         sv_setiv(GvSV(tmpgv),(I32)getpid());
1993
1994 }
1995
1996 static void
1997 init_perllib()
1998 {
1999     char *s;
2000     if (!tainting) {
2001         s = getenv("PERL5LIB");
2002         if (s)
2003             incpush(s);
2004         else
2005             incpush(getenv("PERLLIB"));
2006     }
2007
2008 #ifdef APPLLIB_EXP
2009     incpush(APPLLIB_EXP);
2010 #endif
2011
2012 #ifdef ARCHLIB_EXP
2013     incpush(ARCHLIB_EXP);
2014 #endif
2015 #ifndef PRIVLIB_EXP
2016 #define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
2017 #endif
2018     incpush(PRIVLIB_EXP);
2019
2020 #ifdef SITEARCH_EXP
2021     incpush(SITEARCH_EXP);
2022 #endif
2023 #ifdef SITELIB_EXP
2024     incpush(SITELIB_EXP);
2025 #endif
2026 #ifdef OLDARCHLIB_EXP  /* 5.00[01] compatibility */
2027     incpush(OLDARCHLIB_EXP);
2028 #endif
2029
2030     if (!tainting)
2031         incpush(".");
2032 }
2033
2034 void
2035 calllist(list)
2036 AV* list;
2037 {
2038     Sigjmp_buf oldtop;
2039     STRLEN len;
2040     line_t oldline = curcop->cop_line;
2041
2042     Copy(top_env, oldtop, 1, Sigjmp_buf);
2043
2044     while (AvFILL(list) >= 0) {
2045         CV *cv = (CV*)av_shift(list);
2046
2047         SAVEFREESV(cv);
2048
2049         switch (Sigsetjmp(top_env,1)) {
2050         case 0: {
2051                 SV* atsv = GvSV(errgv);
2052                 PUSHMARK(stack_sp);
2053                 perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
2054                 (void)SvPV(atsv, len);
2055                 if (len) {
2056                     Copy(oldtop, top_env, 1, Sigjmp_buf);
2057                     curcop = &compiling;
2058                     curcop->cop_line = oldline;
2059                     if (list == beginav)
2060                         sv_catpv(atsv, "BEGIN failed--compilation aborted");
2061                     else
2062                         sv_catpv(atsv, "END failed--cleanup aborted");
2063                     croak("%s", SvPVX(atsv));
2064                 }
2065             }
2066             break;
2067         case 1:
2068 #ifdef VMS
2069             statusvalue = 255;  /* XXX I don't think we use 1 anymore. */
2070 #else
2071         statusvalue = 1;
2072 #endif
2073             /* FALL THROUGH */
2074         case 2:
2075             /* my_exit() was called */
2076             curstash = defstash;
2077             if (endav)
2078                 calllist(endav);
2079             FREETMPS;
2080             Copy(oldtop, top_env, 1, Sigjmp_buf);
2081             curcop = &compiling;
2082             curcop->cop_line = oldline;
2083             if (statusvalue) {
2084                 if (list == beginav)
2085                     croak("BEGIN failed--compilation aborted");
2086                 else
2087                     croak("END failed--cleanup aborted");
2088             }
2089             my_exit(statusvalue);
2090             /* NOTREACHED */
2091             return;
2092         case 3:
2093             if (!restartop) {
2094                 fprintf(stderr, "panic: restartop\n");
2095                 FREETMPS;
2096                 break;
2097             }
2098             Copy(oldtop, top_env, 1, Sigjmp_buf);
2099             curcop = &compiling;
2100             curcop->cop_line = oldline;
2101             Siglongjmp(top_env, 3);
2102         }
2103     }
2104
2105     Copy(oldtop, top_env, 1, Sigjmp_buf);
2106 }
2107