perl.c

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