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