perl.c

   1 /*
   2  *    Copyright (c) 1991, 1992, 1993, 1994 Larry Wall
   3  *
   4  *    You may distribute under the terms of either the GNU General Public
   5  *    License or the Artistic License, as specified in the README file.
   6  *
   7  * $Log:        perl.c,v $
   8  * Revision 4.1  92/08/07  18:25:50  lwall
   9  *
  10  * Revision 4.0.1.7  92/06/08  14:50:39  lwall
  11  * patch20: PERLLIB now supports multiple directories
  12  * patch20: running taintperl explicitly now does checks even if $< == $>
  13  * patch20: -e 'cmd' no longer fails silently if /tmp runs out of space
  14  * patch20: perl -P now uses location of sed determined by Configure
  15  * patch20: form feed for formats is now specifiable via $^L
  16  * patch20: paragraph mode now skips extra newlines automatically
  17  * patch20: oldeval "1 #comment" didn't work
  18  * patch20: couldn't require . files
  19  * patch20: semantic compilation errors didn't abort execution
  20  *
  21  * Revision 4.0.1.6  91/11/11  16:38:45  lwall
  22  * patch19: default arg for shift was wrong after first subroutine definition
  23  * patch19: op/regexp.t failed from missing arg to bcmp()
  24  *
  25  * Revision 4.0.1.5  91/11/05  18:03:32  lwall
  26  * patch11: random cleanup
  27  * patch11: $0 was being truncated at times
  28  * patch11: cppstdin now installed outside of source directory
  29  * patch11: -P didn't allow use of #elif or #undef
  30  * patch11: prepared for ctype implementations that don't define isascii()
  31  * patch11: added oldeval {}
  32  * patch11: oldeval confused by string containing null
  33  *
  34  * Revision 4.0.1.4  91/06/10  01:23:07  lwall
  35  * patch10: perl -v printed incorrect copyright notice
  36  *
  37  * Revision 4.0.1.3  91/06/07  11:40:18  lwall
  38  * patch4: changed old $^P to $^X
  39  *
  40  * Revision 4.0.1.2  91/06/07  11:26:16  lwall
  41  * patch4: new copyright notice
  42  * patch4: added $^P variable to control calling of perldb routines
  43  * patch4: added $^F variable to specify maximum system fd, default 2
  44  * patch4: debugger lost track of lines in oldeval
  45  *
  46  * Revision 4.0.1.1  91/04/11  17:49:05  lwall
  47  * patch1: fixed undefined environ problem
  48  *
  49  * Revision 4.0  91/03/20  01:37:44  lwall
  50  * 4.0 baseline.
  51  *
  52  */
  53
  54 /*SUPPRESS 560*/
  55
  56 #include "EXTERN.h"
  57 #include "perl.h"
  58 #include "perly.h"
  59 #include "patchlevel.h"
  60
  61 char rcsid[] = "$RCSfile: perl.c,v $$Revision: 5.0 $$Date: 92/08/07 18:25:50 $\nPatch level: ###\n";
  62
  63 #ifdef IAMSUID
  64 #ifndef DOSUID
  65 #define DOSUID
  66 #endif
  67 #endif
  68
  69 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
  70 #ifdef DOSUID
  71 #undef DOSUID
  72 #endif
  73 #endif
  74
  75 static void incpush();
  76 static void validate_suid();
  77 static void find_beginning();
  78 static void init_main_stash();
  79 static void open_script();
  80 static void init_debugger();
  81 static void init_stack();
  82 static void init_lexer();
  83 static void init_context_stack();
  84 static void init_predump_symbols();
  85 static void init_postdump_symbols();
  86 static void init_perllib();
  87
  88 PerlInterpreter *
  89 perl_alloc()
  90 {
  91     PerlInterpreter *sv_interp;
  92     PerlInterpreter junk;
  93
  94     curinterp = &junk;
  95     Zero(&junk, 1, PerlInterpreter);
  96     New(53, sv_interp, 1, PerlInterpreter);
  97     return sv_interp;
  98 }
  99
 100 void
 101 perl_construct( sv_interp )
 102 register PerlInterpreter *sv_interp;
 103 {
 104     if (!(curinterp = sv_interp))
 105         return;
 106
 107     Zero(sv_interp, 1, PerlInterpreter);
 108
 109     /* Init the real globals? */
 110     if (!linestr) {
 111         linestr = NEWSV(65,80);
 112
 113         SvREADONLY_on(&sv_undef);
 114
 115         sv_setpv(&sv_no,No);
 116         SvNV(&sv_no);
 117         SvREADONLY_on(&sv_no);
 118
 119         sv_setpv(&sv_yes,Yes);
 120         SvNV(&sv_yes);
 121         SvREADONLY_on(&sv_yes);
 122
 123 #ifdef MSDOS
 124         /*
 125          * There is no way we can refer to them from Perl so close them to save
 126          * space.  The other alternative would be to provide STDAUX and STDPRN
 127          * filehandles.
 128          */
 129         (void)fclose(stdaux);
 130         (void)fclose(stdprn);
 131 #endif
 132     }
 133
 134 #ifdef EMBEDDED
 135     chopset     = " \n-";
 136     copline     = NOLINE;
 137     curcop      = &compiling;
 138     cxstack_ix  = -1;
 139     cxstack_max = 128;
 140     dlmax       = 128;
 141     laststatval = -1;
 142     laststype   = OP_STAT;
 143     maxscream   = -1;
 144     maxsysfd    = MAXSYSFD;
 145     nrs         = "\n";
 146     nrschar     = '\n';
 147     nrslen      = 1;
 148     rs          = "\n";
 149     rschar      = '\n';
 150     rsfp        = Nullfp;
 151     rslen       = 1;
 152     statname    = Nullsv;
 153     tmps_floor  = -1;
 154     tmps_ix     = -1;
 155     tmps_max    = -1;
 156 #endif
 157
 158     uid = (int)getuid();
 159     euid = (int)geteuid();
 160     gid = (int)getgid();
 161     egid = (int)getegid();
 162     tainting = (euid != uid || egid != gid);
 163     sprintf(patchlevel,"%3.3s%2.2d", strchr(rcsid,'5'), PATCHLEVEL);
 164
 165     (void)sprintf(strchr(rcsid,'#'), "%d\n", PATCHLEVEL);
 166
 167     fdpid = newAV();    /* for remembering popen pids by fd */
 168     pidstatus = newHV();/* for remembering status of dead pids */
 169 }
 170
 171 void
 172 perl_destruct(sv_interp)
 173 register PerlInterpreter *sv_interp;
 174 {
 175     if (!(curinterp = sv_interp))
 176         return;
 177 #ifdef EMBEDDED
 178     if (main_root)
 179         op_free(main_root);
 180     main_root = 0;
 181 #endif
 182 }
 183
 184 void
 185 perl_free(sv_interp)
 186 PerlInterpreter *sv_interp;
 187 {
 188     if (!(curinterp = sv_interp))
 189         return;
 190     Safefree(sv_interp);
 191 }
 192
 193 int
 194 perl_parse(sv_interp, argc, argv, env)
 195 PerlInterpreter *sv_interp;
 196 register int argc;
 197 register char **argv;
 198 char **env;
 199 {
 200     register SV *sv;
 201     register char *s;
 202     char *scriptname;
 203     char *getenv();
 204     bool dosearch = FALSE;
 205     char *validarg = "";
 206
 207 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
 208 #ifdef IAMSUID
 209 #undef IAMSUID
 210     croak("suidperl is no longer needed since the kernel can now execute\n\
 211 setuid perl scripts securely.\n");
 212 #endif
 213 #endif
 214
 215     if (!(curinterp = sv_interp))
 216         return 255;
 217
 218     if (main_root)
 219         op_free(main_root);
 220     main_root = 0;
 221
 222     origargv = argv;
 223     origargc = argc;
 224     origenviron = environ;
 225
 226     switch (setjmp(top_env)) {
 227     case 1:
 228         statusvalue = 255;
 229     case 2:
 230         return(statusvalue);    /* my_exit() was called */
 231     case 3:
 232         fprintf(stderr, "panic: top_env\n");
 233         exit(1);
 234     }
 235
 236     if (do_undump) {
 237         origfilename = savestr(argv[0]);
 238         do_undump = FALSE;
 239         cxstack_ix = -1;                /* start label stack again */
 240         goto just_doit;
 241     }
 242     sv_setpvn(linestr,"",0);
 243     sv = newSVpv("",0);         /* first used for -I flags */
 244     init_main_stash();
 245     for (argc--,argv++; argc > 0; argc--,argv++) {
 246         if (argv[0][0] != '-' || !argv[0][1])
 247             break;
 248 #ifdef DOSUID
 249     if (*validarg)
 250         validarg = " PHOOEY ";
 251     else
 252         validarg = argv[0];
 253 #endif
 254         s = argv[0]+1;
 255       reswitch:
 256         switch (*s) {
 257         case '0':
 258         case 'a':
 259         case 'c':
 260         case 'd':
 261         case 'D':
 262         case 'i':
 263         case 'l':
 264         case 'n':
 265         case 'p':
 266         case 's':
 267         case 'T':
 268         case 'u':
 269         case 'U':
 270         case 'v':
 271         case 'w':
 272             if (s = moreswitches(s))
 273                 goto reswitch;
 274             break;
 275
 276         case 'e':
 277             if (euid != uid || egid != gid)
 278                 croak("No -e allowed in setuid scripts");
 279             if (!e_fp) {
 280                 e_tmpname = savestr(TMPPATH);
 281                 (void)mktemp(e_tmpname);
 282                 if (!*e_tmpname)
 283                     croak("Can't mktemp()");
 284                 e_fp = fopen(e_tmpname,"w");
 285                 if (!e_fp)
 286                     croak("Cannot open temporary file");
 287             }
 288             if (argv[1]) {
 289                 fputs(argv[1],e_fp);
 290                 argc--,argv++;
 291             }
 292             (void)putc('\n', e_fp);
 293             break;
 294         case 'I':
 295             taint_not("-I");
 296             sv_catpv(sv,"-");
 297             sv_catpv(sv,s);
 298             sv_catpv(sv," ");
 299             if (*++s) {
 300                 (void)av_push(GvAVn(incgv),newSVpv(s,0));
 301             }
 302             else if (argv[1]) {
 303                 (void)av_push(GvAVn(incgv),newSVpv(argv[1],0));
 304                 sv_catpv(sv,argv[1]);
 305                 argc--,argv++;
 306                 sv_catpv(sv," ");
 307             }
 308             break;
 309         case 'P':
 310             taint_not("-P");
 311             preprocess = TRUE;
 312             s++;
 313             goto reswitch;
 314         case 'S':
 315             taint_not("-S");
 316             dosearch = TRUE;
 317             s++;
 318             goto reswitch;
 319         case 'x':
 320             doextract = TRUE;
 321             s++;
 322             if (*s)
 323                 cddir = savestr(s);
 324             break;
 325         case '-':
 326             argc--,argv++;
 327             goto switch_end;
 328         case 0:
 329             break;
 330         default:
 331             croak("Unrecognized switch: -%s",s);
 332         }
 333     }
 334   switch_end:
 335     scriptname = argv[0];
 336     if (e_fp) {
 337         if (fflush(e_fp) || ferror(e_fp) || fclose(e_fp))
 338             croak("Can't write to temp file for -e: %s", strerror(errno));
 339         argc++,argv--;
 340         scriptname = e_tmpname;
 341     }
 342     else if (scriptname == Nullch) {
 343 #ifdef MSDOS
 344         if ( isatty(fileno(stdin)) )
 345             moreswitches("v");
 346 #endif
 347         scriptname = "-";
 348     }
 349
 350     init_perllib();
 351
 352     open_script(scriptname,dosearch,sv);
 353
 354     sv_free(sv);                /* free -I directories */
 355     sv = Nullsv;
 356
 357     validate_suid(validarg);
 358
 359     if (doextract)
 360         find_beginning();
 361
 362     if (perldb)
 363         init_debugger();
 364
 365     pad = newAV();
 366     comppad = pad;
 367     av_push(comppad, Nullsv);
 368     curpad = AvARRAY(comppad);
 369     padname = newAV();
 370     comppadname = padname;
 371     comppadnamefill = -1;
 372     padix = 0;
 373
 374     init_stack();
 375
 376     init_context_stack();
 377
 378     perl_init_ext();    /* in case linked C routines want magical variables */
 379
 380     init_predump_symbols();
 381
 382     init_lexer();
 383
 384     /* now parse the script */
 385
 386     error_count = 0;
 387     if (yyparse() || error_count) {
 388         if (minus_c)
 389             croak("%s had compilation errors.\n", origfilename);
 390         else {
 391             croak("Execution of %s aborted due to compilation errors.\n",
 392                 origfilename);
 393         }
 394     }
 395     curcop->cop_line = 0;
 396     curstash = defstash;
 397     preprocess = FALSE;
 398     if (e_fp) {
 399         e_fp = Nullfp;
 400         (void)UNLINK(e_tmpname);
 401     }
 402
 403     /* now that script is parsed, we can modify record separator */
 404
 405     rs = nrs;
 406     rslen = nrslen;
 407     rschar = nrschar;
 408     rspara = (nrslen == 2);
 409     sv_setpvn(GvSV(gv_fetchpv("/", TRUE)), rs, rslen);
 410
 411     if (do_undump)
 412         my_unexec();
 413
 414   just_doit:            /* come here if running an undumped a.out */
 415     init_postdump_symbols(argc,argv,env);
 416     return 0;
 417 }
 418
 419 int
 420 perl_run(sv_interp)
 421 PerlInterpreter *sv_interp;
 422 {
 423     if (!(curinterp = sv_interp))
 424         return 255;
 425     if (beginav)
 426         calllist(beginav);
 427     switch (setjmp(top_env)) {
 428     case 1:
 429         cxstack_ix = -1;                /* start context stack again */
 430         break;
 431     case 2:
 432         curstash = defstash;
 433         if (endav)
 434             calllist(endav);
 435         return(statusvalue);            /* my_exit() was called */
 436     case 3:
 437         if (!restartop) {
 438             fprintf(stderr, "panic: restartop\n");
 439             exit(1);
 440         }
 441         if (stack != mainstack) {
 442             dSP;
 443             SWITCHSTACK(stack, mainstack);
 444         }
 445         break;
 446     }
 447
 448     if (!restartop) {
 449         DEBUG_x(dump_all());
 450         DEBUG(fprintf(stderr,"\nEXECUTING...\n\n"));
 451
 452         if (minus_c) {
 453             fprintf(stderr,"%s syntax OK\n", origfilename);
 454             my_exit(0);
 455         }
 456     }
 457
 458     /* do it */
 459
 460     if (restartop) {
 461         op = restartop;
 462         restartop = 0;
 463         run();
 464     }
 465     else if (main_start) {
 466         op = main_start;
 467         run();
 468     }
 469
 470     my_exit(0);
 471 }
 472
 473 void
 474 my_exit(status)
 475 int status;
 476 {
 477     statusvalue = (unsigned short)(status & 0xffff);
 478     longjmp(top_env, 2);
 479 }
 480
 481 /* Be sure to refetch the stack pointer after calling these routines. */
 482
 483 int
 484 perl_callback(subname, sp, gimme, hasargs, numargs)
 485 char *subname;
 486 I32 sp;                 /* stack pointer after args are pushed */
 487 I32 gimme;              /* called in array or scalar context */
 488 I32 hasargs;            /* whether to create a @_ array for routine */
 489 I32 numargs;            /* how many args are pushed on the stack */
 490 {
 491     BINOP myop;         /* fake syntax tree node */
 492
 493     ENTER;
 494     SAVETMPS;
 495     SAVESPTR(op);
 496     stack_base = AvARRAY(stack);
 497     stack_sp = stack_base + sp - numargs - 1;
 498     op = (OP*)&myop;
 499     Zero(op, 1, BINOP);
 500     pp_pushmark();      /* doesn't look at op, actually, except to return */
 501     *++stack_sp = (SV*)gv_fetchpv(subname, FALSE);
 502     stack_sp += numargs;
 503
 504     if (hasargs) {
 505         myop.op_flags = OPf_STACKED;
 506         myop.op_last = (OP*)&myop;
 507     }
 508     myop.op_next = Nullop;
 509
 510     if (op = pp_entersubr())
 511         run();
 512     free_tmps();
 513     LEAVE;
 514     return stack_sp - stack_base;
 515 }
 516
 517 int
 518 perl_callv(subname, sp, gimme, argv)
 519 char *subname;
 520 register I32 sp;        /* current stack pointer */
 521 I32 gimme;              /* called in array or scalar context */
 522 register char **argv;   /* null terminated arg list, NULL for no arglist */
 523 {
 524     register I32 items = 0;
 525     I32 hasargs = (argv != 0);
 526
 527     av_store(stack, ++sp, Nullsv);      /* reserve spot for 1st return arg */
 528     if (hasargs) {
 529         while (*argv) {
 530             av_store(stack, ++sp, sv_2mortal(newSVpv(*argv,0)));
 531             items++;
 532             argv++;
 533         }
 534     }
 535     return perl_callback(subname, sp, gimme, hasargs, items);
 536 }
 537
 538 void
 539 magicname(sym,name,namlen)
 540 char *sym;
 541 char *name;
 542 I32 namlen;
 543 {
 544     register GV *gv;
 545
 546     if (gv = gv_fetchpv(sym,TRUE))
 547         sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
 548 }
 549
 550 #ifdef DOSISH
 551 #define PERLLIB_SEP ';'
 552 #else
 553 #define PERLLIB_SEP ':'
 554 #endif
 555
 556 static void
 557 incpush(p)
 558 char *p;
 559 {
 560     char *s;
 561
 562     if (!p)
 563         return;
 564
 565     /* Break at all separators */
 566     while (*p) {
 567         /* First, skip any consecutive separators */
 568         while ( *p == PERLLIB_SEP ) {
 569             /* Uncomment the next line for PATH semantics */
 570             /* (void)av_push(GvAVn(incgv), newSVpv(".", 1)); */
 571             p++;
 572         }
 573         if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
 574             (void)av_push(GvAVn(incgv), newSVpv(p, (I32)(s - p)));
 575             p = s + 1;
 576         } else {
 577             (void)av_push(GvAVn(incgv), newSVpv(p, 0));
 578             break;
 579         }
 580     }
 581 }
 582
 583 /* This routine handles any switches that can be given during run */
 584
 585 char *
 586 moreswitches(s)
 587 char *s;
 588 {
 589     I32 numlen;
 590
 591     switch (*s) {
 592     case '0':
 593         nrschar = scan_oct(s, 4, &numlen);
 594         nrs = nsavestr("\n",1);
 595         *nrs = nrschar;
 596         if (nrschar > 0377) {
 597             nrslen = 0;
 598             nrs = "";
 599         }
 600         else if (!nrschar && numlen >= 2) {
 601             nrslen = 2;
 602             nrs = "\n\n";
 603             nrschar = '\n';
 604         }
 605         return s + numlen;
 606     case 'a':
 607         minus_a = TRUE;
 608         s++;
 609         return s;
 610     case 'c':
 611         minus_c = TRUE;
 612         s++;
 613         return s;
 614     case 'd':
 615         taint_not("-d");
 616         perldb = TRUE;
 617         s++;
 618         return s;
 619     case 'D':
 620 #ifdef DEBUGGING
 621         taint_not("-D");
 622         if (isALPHA(s[1])) {
 623             static char debopts[] = "psltocPmfrxuLHX";
 624             char *d;
 625
 626             for (s++; *s && (d = strchr(debopts,*s)); s++)
 627                 debug |= 1 << (d - debopts);
 628         }
 629         else {
 630             debug = atoi(s+1);
 631             for (s++; isDIGIT(*s); s++) ;
 632         }
 633         debug |= 32768;
 634 #else
 635         warn("Recompile perl with -DDEBUGGING to use -D switch\n");
 636         for (s++; isDIGIT(*s); s++) ;
 637 #endif
 638         /*SUPPRESS 530*/
 639         return s;
 640     case 'i':
 641         if (inplace)
 642             Safefree(inplace);
 643         inplace = savestr(s+1);
 644         /*SUPPRESS 530*/
 645         for (s = inplace; *s && !isSPACE(*s); s++) ;
 646         *s = '\0';
 647         break;
 648     case 'I':
 649         taint_not("-I");
 650         if (*++s) {
 651             (void)av_push(GvAVn(incgv),newSVpv(s,0));
 652         }
 653         else
 654             croak("No space allowed after -I");
 655         break;
 656     case 'l':
 657         minus_l = TRUE;
 658         s++;
 659         if (isDIGIT(*s)) {
 660             ors = savestr("\n");
 661             orslen = 1;
 662             *ors = scan_oct(s, 3 + (*s == '0'), &numlen);
 663             s += numlen;
 664         }
 665         else {
 666             ors = nsavestr(nrs,nrslen);
 667             orslen = nrslen;
 668         }
 669         return s;
 670     case 'n':
 671         minus_n = TRUE;
 672         s++;
 673         return s;
 674     case 'p':
 675         minus_p = TRUE;
 676         s++;
 677         return s;
 678     case 's':
 679         taint_not("-s");
 680         doswitches = TRUE;
 681         s++;
 682         return s;
 683     case 'T':
 684         tainting = TRUE;
 685         s++;
 686         return s;
 687     case 'u':
 688         do_undump = TRUE;
 689         s++;
 690         return s;
 691     case 'U':
 692         unsafe = TRUE;
 693         s++;
 694         return s;
 695     case 'v':
 696         fputs("\nThis is perl, version 5.0, Alpha 4 (unsupported)\n\n",stdout);
 697         fputs(rcsid,stdout);
 698         fputs("\nCopyright (c) 1989, 1990, 1991, 1992, 1993, 1994 Larry Wall\n",stdout);
 699 #ifdef MSDOS
 700         fputs("MS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n",
 701         stdout);
 702 #ifdef OS2
 703         fputs("OS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n",
 704         stdout);
 705 #endif
 706 #endif
 707 #ifdef atarist
 708         fputs("atariST series port, ++jrb  bammi@cadence.com\n", stdout);
 709 #endif
 710         fputs("\n\
 711 Perl may be copied only under the terms of either the Artistic License or the\n\
 712 GNU General Public License, which may be found in the Perl 5.0 source kit.\n",stdout);
 713 #ifdef MSDOS
 714         usage(origargv[0]);
 715 #endif
 716         exit(0);
 717     case 'w':
 718         dowarn = TRUE;
 719         s++;
 720         return s;
 721     case ' ':
 722         if (s[1] == '-')        /* Additional switches on #! line. */
 723             return s+2;
 724         break;
 725     case 0:
 726     case '\n':
 727     case '\t':
 728         break;
 729     default:
 730         croak("Switch meaningless after -x: -%s",s);
 731     }
 732     return Nullch;
 733 }
 734
 735 /* compliments of Tom Christiansen */
 736
 737 /* unexec() can be found in the Gnu emacs distribution */
 738
 739 void
 740 my_unexec()
 741 {
 742 #ifdef UNEXEC
 743     int    status;
 744     extern int etext;
 745
 746     sprintf (buf, "%s.perldump", origfilename);
 747     sprintf (tokenbuf, "%s/perl", BIN);
 748
 749     status = unexec(buf, tokenbuf, &etext, sbrk(0), 0);
 750     if (status)
 751         fprintf(stderr, "unexec of %s into %s failed!\n", tokenbuf, buf);
 752     my_exit(status);
 753 #else
 754     ABORT();            /* for use with undump */
 755 #endif
 756 }
 757
 758 static void
 759 init_main_stash()
 760 {
 761     GV *gv;
 762     curstash = defstash = newHV();
 763     curstname = newSVpv("main",4);
 764     GvHV(gv = gv_fetchpv("_main",TRUE)) = defstash;
 765     SvREADONLY_on(gv);
 766     HvNAME(defstash) = "main";
 767     incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE)));
 768     SvMULTI_on(incgv);
 769     defgv = gv_fetchpv("_",TRUE);
 770 }
 771
 772 static void
 773 open_script(scriptname,dosearch,sv)
 774 char *scriptname;
 775 bool dosearch;
 776 SV *sv;
 777 {
 778     char *xfound = Nullch;
 779     char *xfailed = Nullch;
 780     register char *s;
 781     I32 len;
 782
 783     if (dosearch && !strchr(scriptname, '/') && (s = getenv("PATH"))) {
 784
 785         bufend = s + strlen(s);
 786         while (*s) {
 787 #ifndef DOSISH
 788             s = cpytill(tokenbuf,s,bufend,':',&len);
 789 #else
 790 #ifdef atarist
 791             for (len = 0; *s && *s != ',' && *s != ';'; tokenbuf[len++] = *s++);
 792             tokenbuf[len] = '\0';
 793 #else
 794             for (len = 0; *s && *s != ';'; tokenbuf[len++] = *s++);
 795             tokenbuf[len] = '\0';
 796 #endif
 797 #endif
 798             if (*s)
 799                 s++;
 800 #ifndef DOSISH
 801             if (len && tokenbuf[len-1] != '/')
 802 #else
 803 #ifdef atarist
 804             if (len && ((tokenbuf[len-1] != '\\') && (tokenbuf[len-1] != '/')))
 805 #else
 806             if (len && tokenbuf[len-1] != '\\')
 807 #endif
 808 #endif
 809                 (void)strcat(tokenbuf+len,"/");
 810             (void)strcat(tokenbuf+len,scriptname);
 811             DEBUG_p(fprintf(stderr,"Looking for %s\n",tokenbuf));
 812             if (stat(tokenbuf,&statbuf) < 0)            /* not there? */
 813                 continue;
 814             if (S_ISREG(statbuf.st_mode)
 815              && cando(S_IRUSR,TRUE,&statbuf) && cando(S_IXUSR,TRUE,&statbuf)) {
 816                 xfound = tokenbuf;              /* bingo! */
 817                 break;
 818             }
 819             if (!xfailed)
 820                 xfailed = savestr(tokenbuf);
 821         }
 822         if (!xfound)
 823             croak("Can't execute %s", xfailed ? xfailed : scriptname );
 824         if (xfailed)
 825             Safefree(xfailed);
 826         scriptname = xfound;
 827     }
 828
 829     origfilename = savestr(scriptname);
 830     curcop->cop_filegv = gv_fetchfile(origfilename);
 831     if (strEQ(origfilename,"-"))
 832         scriptname = "";
 833     if (preprocess) {
 834         char *cpp = CPPSTDIN;
 835
 836         if (strEQ(cpp,"cppstdin"))
 837             sprintf(tokenbuf, "%s/%s", SCRIPTDIR, cpp);
 838         else
 839             sprintf(tokenbuf, "%s", cpp);
 840         sv_catpv(sv,"-I");
 841         sv_catpv(sv,PRIVLIB);
 842 #ifdef MSDOS
 843         (void)sprintf(buf, "\
 844 sed %s -e \"/^[^#]/b\" \
 845  -e \"/^#[      ]*include[      ]/b\" \
 846  -e \"/^#[      ]*define[       ]/b\" \
 847  -e \"/^#[      ]*if[   ]/b\" \
 848  -e \"/^#[      ]*ifdef[        ]/b\" \
 849  -e \"/^#[      ]*ifndef[       ]/b\" \
 850  -e \"/^#[      ]*else/b\" \
 851  -e \"/^#[      ]*elif[         ]/b\" \
 852  -e \"/^#[      ]*undef[        ]/b\" \
 853  -e \"/^#[      ]*endif/b\" \
 854  -e \"s/^#.*//\" \
 855  %s | %s -C %s %s",
 856           (doextract ? "-e \"1,/^#/d\n\"" : ""),
 857 #else
 858         (void)sprintf(buf, "\
 859 %s %s -e '/^[^#]/b' \
 860  -e '/^#[       ]*include[      ]/b' \
 861  -e '/^#[       ]*define[       ]/b' \
 862  -e '/^#[       ]*if[   ]/b' \
 863  -e '/^#[       ]*ifdef[        ]/b' \
 864  -e '/^#[       ]*ifndef[       ]/b' \
 865  -e '/^#[       ]*else/b' \
 866  -e '/^#[       ]*elif[         ]/b' \
 867  -e '/^#[       ]*undef[        ]/b' \
 868  -e '/^#[       ]*endif/b' \
 869  -e 's/^[       ]*#.*//' \
 870  %s | %s -C %s %s",
 871 #ifdef LOC_SED
 872           LOC_SED,
 873 #else
 874           "sed",
 875 #endif
 876           (doextract ? "-e '1,/^#/d\n'" : ""),
 877 #endif
 878           scriptname, tokenbuf, SvPV(sv, na), CPPMINUS);
 879         DEBUG_P(fprintf(stderr, "%s\n", buf));
 880         doextract = FALSE;
 881 #ifdef IAMSUID                          /* actually, this is caught earlier */
 882         if (euid != uid && !euid) {     /* if running suidperl */
 883 #ifdef HAS_SETEUID
 884             (void)seteuid(uid);         /* musn't stay setuid root */
 885 #else
 886 #ifdef HAS_SETREUID
 887             (void)setreuid(-1, uid);
 888 #else
 889             setuid(uid);
 890 #endif
 891 #endif
 892             if (geteuid() != uid)
 893                 croak("Can't do seteuid!\n");
 894         }
 895 #endif /* IAMSUID */
 896         rsfp = my_popen(buf,"r");
 897     }
 898     else if (!*scriptname) {
 899         taint_not("program input from stdin");
 900         rsfp = stdin;
 901     }
 902     else
 903         rsfp = fopen(scriptname,"r");
 904     if ((FILE*)rsfp == Nullfp) {
 905 #ifdef DOSUID
 906 #ifndef IAMSUID         /* in case script is not readable before setuid */
 907         if (euid && stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
 908           statbuf.st_mode & (S_ISUID|S_ISGID)) {
 909             (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
 910             execv(buf, origargv);       /* try again */
 911             croak("Can't do setuid\n");
 912         }
 913 #endif
 914 #endif
 915         croak("Can't open perl script \"%s\": %s\n",
 916           SvPVX(GvSV(curcop->cop_filegv)), strerror(errno));
 917     }
 918 }
 919
 920 static void
 921 validate_suid(validarg)
 922 char *validarg;
 923 {
 924     char *s;
 925     /* do we need to emulate setuid on scripts? */
 926
 927     /* This code is for those BSD systems that have setuid #! scripts disabled
 928      * in the kernel because of a security problem.  Merely defining DOSUID
 929      * in perl will not fix that problem, but if you have disabled setuid
 930      * scripts in the kernel, this will attempt to emulate setuid and setgid
 931      * on scripts that have those now-otherwise-useless bits set.  The setuid
 932      * root version must be called suidperl or sperlN.NNN.  If regular perl
 933      * discovers that it has opened a setuid script, it calls suidperl with
 934      * the same argv that it had.  If suidperl finds that the script it has
 935      * just opened is NOT setuid root, it sets the effective uid back to the
 936      * uid.  We don't just make perl setuid root because that loses the
 937      * effective uid we had before invoking perl, if it was different from the
 938      * uid.
 939      *
 940      * DOSUID must be defined in both perl and suidperl, and IAMSUID must
 941      * be defined in suidperl only.  suidperl must be setuid root.  The
 942      * Configure script will set this up for you if you want it.
 943      */
 944
 945 #ifdef DOSUID
 946     if (fstat(fileno(rsfp),&statbuf) < 0)       /* normal stat is insecure */
 947         croak("Can't stat script \"%s\"",origfilename);
 948     if (statbuf.st_mode & (S_ISUID|S_ISGID)) {
 949         I32 len;
 950
 951 #ifdef IAMSUID
 952 #ifndef HAS_SETREUID
 953         /* On this access check to make sure the directories are readable,
 954          * there is actually a small window that the user could use to make
 955          * filename point to an accessible directory.  So there is a faint
 956          * chance that someone could execute a setuid script down in a
 957          * non-accessible directory.  I don't know what to do about that.
 958          * But I don't think it's too important.  The manual lies when
 959          * it says access() is useful in setuid programs.
 960          */
 961         if (access(SvPVX(GvSV(curcop->cop_filegv)),1))  /*double check*/
 962             croak("Permission denied");
 963 #else
 964         /* If we can swap euid and uid, then we can determine access rights
 965          * with a simple stat of the file, and then compare device and
 966          * inode to make sure we did stat() on the same file we opened.
 967          * Then we just have to make sure he or she can execute it.
 968          */
 969         {
 970             struct stat tmpstatbuf;
 971
 972             if (setreuid(euid,uid) < 0 || getuid() != euid || geteuid() != uid)
 973                 croak("Can't swap uid and euid");       /* really paranoid */
 974             if (stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0)
 975                 croak("Permission denied");     /* testing full pathname here */
 976             if (tmpstatbuf.st_dev != statbuf.st_dev ||
 977                 tmpstatbuf.st_ino != statbuf.st_ino) {
 978                 (void)fclose(rsfp);
 979                 if (rsfp = my_popen("/bin/mail root","w")) {    /* heh, heh */
 980                     fprintf(rsfp,
 981 "User %d tried to run dev %d ino %d in place of dev %d ino %d!\n\
 982 (Filename of set-id script was %s, uid %d gid %d.)\n\nSincerely,\nperl\n",
 983                         uid,tmpstatbuf.st_dev, tmpstatbuf.st_ino,
 984                         statbuf.st_dev, statbuf.st_ino,
 985                         SvPVX(GvSV(curcop->cop_filegv)),
 986                         statbuf.st_uid, statbuf.st_gid);
 987                     (void)my_pclose(rsfp);
 988                 }
 989                 croak("Permission denied\n");
 990             }
 991             if (setreuid(uid,euid) < 0 || getuid() != uid || geteuid() != euid)
 992                 croak("Can't reswap uid and euid");
 993             if (!cando(S_IXUSR,FALSE,&statbuf))         /* can real uid exec? */
 994                 croak("Permission denied\n");
 995         }
 996 #endif /* HAS_SETREUID */
 997 #endif /* IAMSUID */
 998
 999         if (!S_ISREG(statbuf.st_mode))
1000             croak("Permission denied");
1001         if (statbuf.st_mode & S_IWOTH)
1002             croak("Setuid/gid script is writable by world");
1003         doswitches = FALSE;             /* -s is insecure in suid */
1004         curcop->cop_line++;
1005         if (fgets(tokenbuf,sizeof tokenbuf, rsfp) == Nullch ||
1006           strnNE(tokenbuf,"#!",2) )     /* required even on Sys V */
1007             croak("No #! line");
1008         s = tokenbuf+2;
1009         if (*s == ' ') s++;
1010         while (!isSPACE(*s)) s++;
1011         if (strnNE(s-4,"perl",4) && strnNE(s-9,"perl",4))  /* sanity check */
1012             croak("Not a perl script");
1013         while (*s == ' ' || *s == '\t') s++;
1014         /*
1015          * #! arg must be what we saw above.  They can invoke it by
1016          * mentioning suidperl explicitly, but they may not add any strange
1017          * arguments beyond what #! says if they do invoke suidperl that way.
1018          */
1019         len = strlen(validarg);
1020         if (strEQ(validarg," PHOOEY ") ||
1021             strnNE(s,validarg,len) || !isSPACE(s[len]))
1022             croak("Args must match #! line");
1023
1024 #ifndef IAMSUID
1025         if (euid != uid && (statbuf.st_mode & S_ISUID) &&
1026             euid == statbuf.st_uid)
1027             if (!do_undump)
1028                 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
1029 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
1030 #endif /* IAMSUID */
1031
1032         if (euid) {     /* oops, we're not the setuid root perl */
1033             (void)fclose(rsfp);
1034 #ifndef IAMSUID
1035             (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
1036             execv(buf, origargv);       /* try again */
1037 #endif
1038             croak("Can't do setuid\n");
1039         }
1040
1041         if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) {
1042 #ifdef HAS_SETEGID
1043             (void)setegid(statbuf.st_gid);
1044 #else
1045 #ifdef HAS_SETREGID
1046             (void)setregid((GIDTYPE)-1,statbuf.st_gid);
1047 #else
1048             setgid(statbuf.st_gid);
1049 #endif
1050 #endif
1051             if (getegid() != statbuf.st_gid)
1052                 croak("Can't do setegid!\n");
1053         }
1054         if (statbuf.st_mode & S_ISUID) {
1055             if (statbuf.st_uid != euid)
1056 #ifdef HAS_SETEUID
1057                 (void)seteuid(statbuf.st_uid);  /* all that for this */
1058 #else
1059 #ifdef HAS_SETREUID
1060                 (void)setreuid((UIDTYPE)-1,statbuf.st_uid);
1061 #else
1062                 setuid(statbuf.st_uid);
1063 #endif
1064 #endif
1065             if (geteuid() != statbuf.st_uid)
1066                 croak("Can't do seteuid!\n");
1067         }
1068         else if (uid) {                 /* oops, mustn't run as root */
1069 #ifdef HAS_SETEUID
1070             (void)seteuid((UIDTYPE)uid);
1071 #else
1072 #ifdef HAS_SETREUID
1073             (void)setreuid((UIDTYPE)-1,(UIDTYPE)uid);
1074 #else
1075             setuid((UIDTYPE)uid);
1076 #endif
1077 #endif
1078             if (geteuid() != uid)
1079                 croak("Can't do seteuid!\n");
1080         }
1081         uid = (int)getuid();
1082         euid = (int)geteuid();
1083         gid = (int)getgid();
1084         egid = (int)getegid();
1085         tainting |= (euid != uid || egid != gid);
1086         if (!cando(S_IXUSR,TRUE,&statbuf))
1087             croak("Permission denied\n");       /* they can't do this */
1088     }
1089 #ifdef IAMSUID
1090     else if (preprocess)
1091         croak("-P not allowed for setuid/setgid script\n");
1092     else
1093         croak("Script is not setuid/setgid in suidperl\n");
1094 #endif /* IAMSUID */
1095 #else /* !DOSUID */
1096     if (euid != uid || egid != gid) {   /* (suidperl doesn't exist, in fact) */
1097 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
1098         fstat(fileno(rsfp),&statbuf);   /* may be either wrapped or real suid */
1099         if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
1100             ||
1101             (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
1102            )
1103             if (!do_undump)
1104                 croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
1105 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
1106 #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
1107         /* not set-id, must be wrapped */
1108     }
1109 #endif /* DOSUID */
1110 }
1111
1112 static void
1113 find_beginning()
1114 {
1115     register char *s;
1116
1117     /* skip forward in input to the real script? */
1118
1119     taint_not("-x");
1120     while (doextract) {
1121         if ((s = sv_gets(linestr, rsfp, 0)) == Nullch)
1122             croak("No Perl script found in input\n");
1123         if (*s == '#' && s[1] == '!' && instr(s,"perl")) {
1124             ungetc('\n',rsfp);          /* to keep line count right */
1125             doextract = FALSE;
1126             if (s = instr(s,"perl -")) {
1127                 s += 6;
1128                 /*SUPPRESS 530*/
1129                 while (s = moreswitches(s)) ;
1130             }
1131             if (cddir && chdir(cddir) < 0)
1132                 croak("Can't chdir to %s",cddir);
1133         }
1134     }
1135 }
1136
1137 static void
1138 init_debugger()
1139 {
1140     GV* tmpgv;
1141
1142     debstash = newHV();
1143     GvHV(gv_fetchpv("_DB",TRUE)) = debstash;
1144     curstash = debstash;
1145     dbargs = GvAV(gv_AVadd((tmpgv = gv_fetchpv("args",TRUE))));
1146     SvMULTI_on(tmpgv);
1147     AvREAL_off(dbargs);
1148     DBgv = gv_fetchpv("DB",TRUE);
1149     SvMULTI_on(DBgv);
1150     DBline = gv_fetchpv("dbline",TRUE);
1151     SvMULTI_on(DBline);
1152     DBsub = gv_HVadd(tmpgv = gv_fetchpv("sub",TRUE));
1153     SvMULTI_on(tmpgv);
1154     DBsingle = GvSV((tmpgv = gv_fetchpv("single",TRUE)));
1155     SvMULTI_on(tmpgv);
1156     DBtrace = GvSV((tmpgv = gv_fetchpv("trace",TRUE)));
1157     SvMULTI_on(tmpgv);
1158     DBsignal = GvSV((tmpgv = gv_fetchpv("signal",TRUE)));
1159     SvMULTI_on(tmpgv);
1160     curstash = defstash;
1161 }
1162
1163 static void
1164 init_stack()
1165 {
1166     stack = newAV();
1167     mainstack = stack;                  /* remember in case we switch stacks */
1168     AvREAL_off(stack);                  /* not a real array */
1169     av_fill(stack,127); av_fill(stack,-1);      /* preextend stack */
1170
1171     stack_base = AvARRAY(stack);
1172     stack_sp = stack_base;
1173     stack_max = stack_base + 128;
1174
1175     New(54,markstack,64,int);
1176     markstack_ptr = markstack;
1177     markstack_max = markstack + 64;
1178
1179     New(54,scopestack,32,int);
1180     scopestack_ix = 0;
1181     scopestack_max = 32;
1182
1183     New(54,savestack,128,ANY);
1184     savestack_ix = 0;
1185     savestack_max = 128;
1186
1187     New(54,retstack,16,OP*);
1188     retstack_ix = 0;
1189     retstack_max = 16;
1190 }
1191
1192 static void
1193 init_lexer()
1194 {
1195     bufend = bufptr = SvPV(linestr, na);
1196     subname = newSVpv("main",4);
1197     lex_start();                /* we never leave */
1198 }
1199
1200 static void
1201 init_context_stack()
1202 {
1203     New(50,cxstack,128,CONTEXT);
1204     DEBUG( {
1205         New(51,debname,128,char);
1206         New(52,debdelim,128,char);
1207     } )
1208 }
1209
1210 static void
1211 init_predump_symbols()
1212 {
1213     GV *tmpgv;
1214
1215     sv_setpvn(GvSV(gv_fetchpv("\"", TRUE)), " ", 1);
1216
1217     stdingv = gv_fetchpv("STDIN",TRUE);
1218     SvMULTI_on(stdingv);
1219     if (!GvIO(stdingv))
1220         GvIO(stdingv) = newIO();
1221     GvIO(stdingv)->ifp = stdin;
1222     tmpgv = gv_fetchpv("stdin",TRUE);
1223     GvIO(tmpgv) = GvIO(stdingv);
1224     SvMULTI_on(tmpgv);
1225
1226     tmpgv = gv_fetchpv("STDOUT",TRUE);
1227     SvMULTI_on(tmpgv);
1228     if (!GvIO(tmpgv))
1229         GvIO(tmpgv) = newIO();
1230     GvIO(tmpgv)->ofp = GvIO(tmpgv)->ifp = stdout;
1231     defoutgv = tmpgv;
1232     tmpgv = gv_fetchpv("stdout",TRUE);
1233     GvIO(tmpgv) = GvIO(defoutgv);
1234     SvMULTI_on(tmpgv);
1235
1236     curoutgv = gv_fetchpv("STDERR",TRUE);
1237     SvMULTI_on(curoutgv);
1238     if (!GvIO(curoutgv))
1239         GvIO(curoutgv) = newIO();
1240     GvIO(curoutgv)->ofp = GvIO(curoutgv)->ifp = stderr;
1241     tmpgv = gv_fetchpv("stderr",TRUE);
1242     GvIO(tmpgv) = GvIO(curoutgv);
1243     SvMULTI_on(tmpgv);
1244     curoutgv = defoutgv;                /* switch back to STDOUT */
1245
1246     statname = NEWSV(66,0);             /* last filename we did stat on */
1247 }
1248
1249 static void
1250 init_postdump_symbols(argc,argv,env)
1251 register int argc;
1252 register char **argv;
1253 register char **env;
1254 {
1255     char *s;
1256     SV *sv;
1257     GV* tmpgv;
1258
1259     argc--,argv++;      /* skip name of script */
1260     if (doswitches) {
1261         for (; argc > 0 && **argv == '-'; argc--,argv++) {
1262             if (!argv[0][1])
1263                 break;
1264             if (argv[0][1] == '-') {
1265                 argc--,argv++;
1266                 break;
1267             }
1268             if (s = strchr(argv[0], '=')) {
1269                 *s++ = '\0';
1270                 sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE)),s);
1271             }
1272             else
1273                 sv_setiv(GvSV(gv_fetchpv(argv[0]+1,TRUE)),1);
1274         }
1275     }
1276     toptarget = NEWSV(0,0);
1277     sv_upgrade(toptarget, SVt_PVFM);
1278     sv_setpvn(toptarget, "", 0);
1279     bodytarget = NEWSV(0,0);
1280     sv_upgrade(bodytarget, SVt_PVFM);
1281     sv_setpvn(bodytarget, "", 0);
1282     formtarget = bodytarget;
1283
1284     tainted = 1;
1285     if (tmpgv = gv_fetchpv("0",TRUE)) {
1286         sv_setpv(GvSV(tmpgv),origfilename);
1287         magicname("0", "0", 1);
1288     }
1289     if (tmpgv = gv_fetchpv("\024",TRUE))
1290         time(&basetime);
1291     if (tmpgv = gv_fetchpv("\030",TRUE))
1292         sv_setpv(GvSV(tmpgv),origargv[0]);
1293     if (argvgv = gv_fetchpv("ARGV",TRUE)) {
1294         SvMULTI_on(argvgv);
1295         (void)gv_AVadd(argvgv);
1296         av_clear(GvAVn(argvgv));
1297         for (; argc > 0; argc--,argv++) {
1298             (void)av_push(GvAVn(argvgv),newSVpv(argv[0],0));
1299         }
1300     }
1301     if (envgv = gv_fetchpv("ENV",TRUE)) {
1302         HV *hv;
1303         SvMULTI_on(envgv);
1304         hv = GvHVn(envgv);
1305         hv_clear(hv);
1306         if (env != environ)
1307             environ[0] = Nullch;
1308         for (; *env; env++) {
1309             if (!(s = strchr(*env,'=')))
1310                 continue;
1311             *s++ = '\0';
1312             sv = newSVpv(s--,0);
1313             (void)hv_store(hv, *env, s - *env, sv, 0);
1314             *s = '=';
1315         }
1316         hv_magic(hv, envgv, 'E');
1317     }
1318     tainted = 0;
1319     if (tmpgv = gv_fetchpv("$",TRUE))
1320         sv_setiv(GvSV(tmpgv),(I32)getpid());
1321
1322     if (dowarn)
1323         gv_check(defstash);
1324 }
1325
1326 static void
1327 init_perllib()
1328 {
1329     if (!tainting)
1330         incpush(getenv("PERLLIB"));
1331
1332 #ifndef PRIVLIB
1333 #define PRIVLIB "/usr/local/lib/perl"
1334 #endif
1335     incpush(PRIVLIB);
1336     (void)av_push(GvAVn(incgv),newSVpv(".",1));
1337 }
1338
1339 void
1340 calllist(list)
1341 AV* list;
1342 {
1343     I32 i;
1344     I32 fill = AvFILL(list);
1345     jmp_buf oldtop;
1346     I32 sp = stack_sp - stack_base;
1347
1348     av_store(stack, ++sp, Nullsv);      /* reserve spot for 1st return arg */
1349     Copy(top_env, oldtop, 1, jmp_buf);
1350
1351     for (i = 0; i <= fill; i++)
1352     {
1353         GV *gv = (GV*)av_shift(list);
1354         SV* tmpsv = NEWSV(0,0);
1355
1356         if (gv && GvCV(gv)) {
1357             gv_efullname(tmpsv, gv);
1358             if (setjmp(top_env)) {
1359                 if (list == beginav)
1360                     exit(1);
1361             }
1362             else {
1363                 perl_callback(SvPVX(tmpsv), sp, G_SCALAR, 0, 0);
1364             }
1365         }
1366         sv_free(tmpsv);
1367         sv_free(gv);
1368     }
1369
1370     Copy(oldtop, top_env, 1, jmp_buf);
1371 }
1372