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