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