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