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