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