home *** CD-ROM | disk | FTP | other *** search
/ APDL Public Domain 1 / APDL_PD1A.iso / program / language / perl / Source / C / Perly < prev    next >
Encoding:
Text File  |  1991-02-09  |  22.0 KB  |  931 lines
  1. char rcsid[] = "$Header: perly.c,v 3.0.1.10 91/01/11 18:22:48 lwall Locked $\nPatch level: ###\n";
  2. /*
  3.  *    Copyright (c) 1989, Larry Wall
  4.  *
  5.  *    You may distribute under the terms of the GNU General Public License
  6.  *    as specified in the README file that comes with the perl 3.0 kit.
  7.  *
  8.  * $Log:    perly.c,v $
  9.  * Revision 3.0.1.10  91/01/11  18:22:48  lwall
  10.  * patch42: added -0 option
  11.  * patch42: ANSIfied the stat mode checking
  12.  * patch42: executables for multiple versions may now coexist
  13.  * 
  14.  * Revision 3.0.1.9  90/11/10  01:53:26  lwall
  15.  * patch38: random cleanup
  16.  * patch38: more msdos/os2 upgrades
  17.  * patch38: references to $0 produced core dumps
  18.  * patch38: added hooks for unexec()
  19.  * 
  20.  * Revision 3.0.1.8  90/10/16  10:14:20  lwall
  21.  * patch29: *foo now prints as *package'foo
  22.  * patch29: added waitpid
  23.  * patch29: the debugger now understands packages and evals
  24.  * patch29: added -M, -A and -C
  25.  * patch29: -w sometimes printed spurious warnings about ARGV and ENV
  26.  * patch29: require "./foo" didn't work right
  27.  * patch29: require error messages referred to wrong file
  28.  * 
  29.  * Revision 3.0.1.7  90/08/13  22:22:22  lwall
  30.  * patch28: defined(@array) and defined(%array) didn't work right
  31.  * 
  32.  * Revision 3.0.1.6  90/08/09  04:55:50  lwall
  33.  * patch19: added -x switch to extract script from input trash
  34.  * patch19: Added -c switch to do compilation only
  35.  * patch19: added numeric interpretation of $]
  36.  * patch19: added require operator
  37.  * patch19: $0, %ENV, @ARGV were wrong in dumped script
  38.  * patch19: . is now explicitly in @INC (and last)
  39.  * 
  40.  * Revision 3.0.1.5  90/03/27  16:20:57  lwall
  41.  * patch16: MSDOS support
  42.  * patch16: do FILE inside eval blows up
  43.  * 
  44.  * Revision 3.0.1.4  90/02/28  18:06:41  lwall
  45.  * patch9: perl can now start up other interpreters scripts
  46.  * patch9: nested evals clobbered their longjmp environment
  47.  * patch9: eval could mistakenly return undef in array context
  48.  * 
  49.  * Revision 3.0.1.3  89/12/21  20:15:41  lwall
  50.  * patch7: ANSI strerror() is now supported
  51.  * patch7: errno may now be a macro with an lvalue
  52.  * patch7: allowed setuid scripts to have a space after #!
  53.  * 
  54.  * Revision 3.0.1.2  89/11/17  15:34:42  lwall
  55.  * patch5: fixed possible confusion about current effective gid
  56.  * 
  57.  * Revision 3.0.1.1  89/11/11  04:50:04  lwall
  58.  * patch2: moved yydebug to where its type didn't matter
  59.  * 
  60.  * Revision 3.0  89/10/18  15:22:21  lwall
  61.  * 3.0 baseline
  62.  * 
  63.  */
  64.  
  65. #include "EXTERN.h"
  66. #include "perl.h"
  67. #include "perly.h"
  68. #include "patchlevel.h"
  69.  
  70. static char *moreswitches PROTO((char *));
  71. static char *cddir;
  72. static bool minus_c;
  73. static char patchlevel[6];
  74.  
  75. int
  76. main(argc,argv)
  77. register int argc;
  78. register char **argv;
  79. {
  80.     register STR *str;
  81.     register char *s;
  82.     char *val;
  83.     bool dosearch = FALSE;
  84.  
  85.     origargv = argv;
  86.     origargc = argc;
  87.     sprintf(patchlevel,"%3.3s%2.2d", rcsid+19, PATCHLEVEL);
  88.  
  89.     (void)sprintf(index(rcsid,'#'), "%d\n", PATCHLEVEL);
  90.     linestr = Str_new(65,80);
  91.     str_nset(linestr,"",0);
  92.     str = str_make("",0);        /* first used for -I flags */
  93.     curstash = defstash = hnew(0);
  94.     curstname = str_make("main",4);
  95.     stab_xhash(stabent("_main",TRUE)) = defstash;
  96.     defstash->tbl_name = "main";
  97.     incstab = hadd(aadd(stabent("INC",TRUE)));
  98.     incstab->str_pok |= SP_MULTI;
  99.     for (argc--,argv++; argc > 0; argc--,argv++) {
  100.     if (argv[0][0] != '-' || !argv[0][1])
  101.         break;
  102.     s = argv[0]+1;
  103.       reswitch:
  104.     switch (*s) {
  105.     case '0':
  106.     case 'a':
  107.     case 'c':
  108.     case 'd':
  109.     case 'D':
  110.     case 'i':
  111.     case 'n':
  112.     case 'p':
  113.     case 'u':
  114.     case 'U':
  115.     case 'v':
  116.     case 'w':
  117.         if ((s = moreswitches(s)) != Nullch)
  118.         goto reswitch;
  119.         break;
  120.  
  121.     case 'e':
  122. #ifdef TAINT
  123.         if (euid != uid || egid != gid)
  124.         fatal("No -e allowed in setuid scripts");
  125. #endif
  126.         if (!e_fp) {
  127.             e_tmpname = savestr(TMPPATH);
  128.         (void)mktemp(e_tmpname);
  129.         e_fp = fopen(e_tmpname,"w");
  130.         if (!e_fp)
  131.             fatal("Cannot open temporary file");
  132.         }
  133.         if (argv[1]) {
  134.         fputs(argv[1],e_fp);
  135.         argc--,argv++;
  136.         }
  137.         (void)putc('\n', e_fp);
  138.         break;
  139.     case 'I':
  140. #ifdef TAINT
  141.         if (euid != uid || egid != gid)
  142.         fatal("No -I allowed in setuid scripts");
  143. #endif
  144.         str_cat(str,"-");
  145.         str_cat(str,s);
  146.         str_cat(str," ");
  147.         if (*++s) {
  148.         (void)apush(stab_array(incstab),str_make(s,0));
  149.         }
  150.         else if (argv[1]) {
  151.         (void)apush(stab_array(incstab),str_make(argv[1],0));
  152.         str_cat(str,argv[1]);
  153.         argc--,argv++;
  154.         str_cat(str," ");
  155.         }
  156.         break;
  157.     case 'P':
  158. #ifdef TAINT
  159.         if (euid != uid || egid != gid)
  160.         fatal("No -P allowed in setuid scripts");
  161. #endif
  162.         preprocess = TRUE;
  163.         s++;
  164.         goto reswitch;
  165.     case 's':
  166. #ifdef TAINT
  167.         if (euid != uid || egid != gid)
  168.         fatal("No -s allowed in setuid scripts");
  169. #endif
  170.         doswitches = TRUE;
  171.         s++;
  172.         goto reswitch;
  173.     case 'S':
  174.         dosearch = TRUE;
  175.         s++;
  176.         goto reswitch;
  177.     case 'x':
  178.         doextract = TRUE;
  179.         s++;
  180.         if (*s)
  181.         cddir = savestr(s);
  182.         break;
  183.     case '-':
  184.         argc--,argv++;
  185.         goto switch_end;
  186.     case 0:
  187.         break;
  188.     default:
  189.         fatal("Unrecognized switch: -%s",s);
  190.     }
  191.     }
  192.   switch_end:
  193.     if (e_fp) {
  194.     (void)fclose(e_fp);
  195.     argc++,argv--;
  196.     argv[0] = e_tmpname;
  197.     }
  198. #ifndef PRIVLIB
  199. #define PRIVLIB "Lib:Perl"
  200. #endif
  201.     (void)apush(stab_array(incstab),str_make(PRIVLIB,0));
  202.     (void)apush(stab_array(incstab),str_make("@",1));
  203.  
  204.     str_set(&str_no,No);
  205.     str_set(&str_yes,Yes);
  206.  
  207.     /* open script */
  208.  
  209.     if (argv[0] == Nullch)
  210.     argv[0] = "-";
  211. #if 0
  212.     if (dosearch && !index(argv[0], '/') && (s = getenv("PATH")) != Nullch) {
  213.     char *xfound = Nullch, *xfailed = Nullch;
  214.     int len;
  215.  
  216.     bufend = s + strlen(s);
  217.     while (*s) {
  218. #ifndef MSDOS
  219.         s = cpytill(tokenbuf,s,bufend,':',&len);
  220. #else
  221.         for (len = 0; *s && *s != ';'; tokenbuf[len++] = *s++);
  222.         tokenbuf[len] = '\0';
  223. #endif
  224.         if (*s)
  225.         s++;
  226. #ifndef MSDOS
  227.         if (len && tokenbuf[len-1] != '/')
  228. #else
  229.         if (len && tokenbuf[len-1] != '\\')
  230. #endif
  231.         (void)strcat(tokenbuf+len,"/");
  232.         (void)strcat(tokenbuf+len,argv[0]);
  233. #ifdef DEBUGGING
  234.         if (debug & 1)
  235.         fprintf(stderr,"Looking for %s\n",tokenbuf);
  236. #endif
  237.         if (stat(tokenbuf,&statbuf) < 0)        /* not there? */
  238.         continue;
  239.         if (statbuf.st_type == T_FILE) {
  240.         xfound = tokenbuf;              /* bingo! */
  241.         break;
  242.         }
  243.         if (!xfailed)
  244.         xfailed = savestr(tokenbuf);
  245.     }
  246.     if (!xfound)
  247.         fatal("Can't execute %s", xfailed ? xfailed : argv[0] );
  248.     if (xfailed)
  249.         Safefree(xfailed);
  250.     argv[0] = savestr(xfound);
  251.     }
  252. #endif
  253.  
  254.     origfilename = savestr(argv[0]);
  255.     curcmd->c_filestab = fstab(origfilename);
  256.     if (strEQ(origfilename,"-"))
  257.     argv[0] = "";
  258.  
  259.     if (preprocess) {
  260.         FILE *fp1 = (*argv[0] ? fopen(argv[0],"r") : stdin);
  261.         FILE *fp2;
  262.         char *tmp = mktemp("CppTmp");
  263.     int ch;
  264.     int nl = 1;
  265.     char line_buf[10];
  266.     int i;
  267.     
  268.     if (fp1 == Nullfp) {
  269.         _kernel_oserror *ep;
  270.         if (ep)
  271.         fatal("Can't open perl script \"%s\": %s\n",
  272.               origfilename, ep->errmess);
  273.         else
  274.         fatal("Can't open perl script \"%s\"\n", origfilename);
  275.     }
  276.  
  277.     if (tmp == Nullch || (fp2 = fopen(tmp,"w")) == Nullfp)
  278.         fatal("Can't open temporary file for preprocessing\n");
  279.  
  280.     while ((ch = getc(fp1)) != EOF)
  281.     {
  282.         if (ch == '\n')
  283.         {
  284.         nl = 1;
  285.         putc(ch,fp2);
  286.         continue;
  287.         }
  288.  
  289.         if (!nl || ch != '#')
  290.         {
  291.         nl = 0;
  292.         putc(ch,fp2);
  293.         continue;
  294.         }
  295.  
  296.         /* We have a '#' at the start of the line */
  297.  
  298.         /* Skip space */
  299.         for (ch = getc(fp1); ch == ' ' || ch == '\t'; ch = getc(fp1))
  300.         ;
  301.  
  302.         /* get the command */
  303.         for (i = 0; i < 10;)
  304.         {
  305.         line_buf[i++] = ch;
  306.  
  307.         ch = getc(fp1);
  308.         if (ch == EOF || isspace(ch))
  309.             break;
  310.         }
  311.  
  312.         /* Check that it's the correct length for a command */
  313.         if (i != 2 && (i < 4 || i > 7))
  314.         goto skip_line;
  315.  
  316.         /* Check for preprocessor keywords */
  317.         switch (line_buf[0])
  318.         {
  319.         case 'i':
  320.         if (i == 2 && strnEQ(line_buf,"if",2))
  321.             goto keep_line;
  322.         if (i == 5 && strnEQ(line_buf,"ifdef",5))
  323.             goto keep_line;
  324.         if (i == 6 && strnEQ(line_buf,"ifndef",6))
  325.             goto keep_line;
  326.         if (i == 7 && strnEQ(line_buf,"include",7))
  327.             goto keep_line;
  328.         goto skip_line;
  329.         case 'e':
  330.         if (i == 4 && strnEQ(line_buf,"else",4))
  331.             goto keep_line;
  332.         if (i == 5 && strnEQ(line_buf,"endif",5))
  333.             goto keep_line;
  334.         goto skip_line;
  335.         case 'd':
  336.         if (i == 6 && strnEQ(line_buf,"define",6))
  337.             goto keep_line;
  338.         goto skip_line;
  339.         default:
  340.         goto skip_line;
  341.         }
  342. keep_line:
  343.         /* Keep this line */
  344.         putc('#',fp2);
  345.         fwrite(line_buf,i,1,fp2);
  346.  
  347.         while (ch != EOF)
  348.         {
  349.         putc(ch,fp2);
  350.         if (ch == '\n')
  351.             break;
  352.         ch = getc(fp1);
  353.         }
  354.  
  355.         nl = 1;
  356.  
  357. skip_line:
  358.         /* Skip the rest of the line */
  359.         while (ch != EOF && ch != '\n')
  360.         ch = getc(fp1);
  361.  
  362.         nl = 1;
  363.     }
  364.  
  365.     fclose(fp1);
  366.     fclose(fp2);
  367.  
  368.     str_cat(str,"-I");
  369.     str_cat(str,PRIVLIB);
  370.  
  371.     (void)sprintf(buf, "cc -E -C -pcc %s - < %s 2>Null:",
  372.               str_get(str), tmp);
  373.     rsfp = mypopen(buf,"r");
  374.  
  375.     remove(tmp);
  376.     free(tmp);
  377.     }
  378.     else if (!*argv[0])
  379.     rsfp = stdin;
  380.     else
  381.     rsfp = fopen(argv[0],"r");
  382.  
  383.     if (rsfp == Nullfp) {
  384.     _kernel_oserror *ep;
  385.     if (ep)
  386.         fatal("Can't open perl script \"%s\": %s\n",
  387.           stab_val(curcmd->c_filestab)->str_ptr, ep->errmess);
  388.     else
  389.         fatal("Can't open perl script \"%s\"\n",
  390.           stab_val(curcmd->c_filestab)->str_ptr);
  391.     }
  392.     str_free(str);        /* free -I directories */
  393.  
  394.     /* skip forward in input to the real script? */
  395.  
  396.     while (doextract) {
  397.     if ((s = str_gets(linestr, rsfp, 0)) == Nullch)
  398.         fatal("No Perl script found in input\n");
  399.     if (*s == '#' && s[1] == '!' && instr(s,"perl")) {
  400.         ungetc('\n',rsfp);        /* to keep line count right */
  401.         doextract = FALSE;
  402.         if ((s = instr(s,"perl -")) != Nullch) {
  403.         s += 6;
  404.         while ((s = moreswitches(s)) != Nullch) ;
  405.         }
  406.         if (cddir && chdir(cddir) < 0)
  407.         fatal("Can't chdir to %s",cddir);
  408.     }
  409.     }
  410.  
  411.     defstab = stabent("_",TRUE);
  412.  
  413.     if (perldb) {
  414.     debstash = hnew(0);
  415.     stab_xhash(stabent("_DB",TRUE)) = debstash;
  416.     curstash = debstash;
  417.     dbargs = stab_xarray(aadd((tmpstab = stabent("args",TRUE))));
  418.     tmpstab->str_pok |= SP_MULTI;
  419.     dbargs->ary_flags = 0;
  420.     subname = str_make("main",4);
  421.     DBstab = stabent("DB",TRUE);
  422.     DBstab->str_pok |= SP_MULTI;
  423.     DBline = stabent("dbline",TRUE);
  424.     DBline->str_pok |= SP_MULTI;
  425.     DBsub = hadd(tmpstab = stabent("sub",TRUE));
  426.     tmpstab->str_pok |= SP_MULTI;
  427.     DBsingle = stab_val((tmpstab = stabent("single",TRUE)));
  428.     tmpstab->str_pok |= SP_MULTI;
  429.     DBtrace = stab_val((tmpstab = stabent("trace",TRUE)));
  430.     tmpstab->str_pok |= SP_MULTI;
  431.     DBsignal = stab_val((tmpstab = stabent("signal",TRUE)));
  432.     tmpstab->str_pok |= SP_MULTI;
  433.     curstash = defstash;
  434.     }
  435.  
  436.     /* init tokener */
  437.  
  438.     bufend = bufptr = str_get(linestr);
  439.  
  440.     savestack = anew(Nullstab);        /* for saving non-local values */
  441.     stack = anew(Nullstab);        /* for saving non-local values */
  442.     stack->ary_flags = 0;        /* not a real array */
  443.     afill(stack,63); afill(stack,-1);    /* preextend stack */
  444.     afill(savestack,63); afill(savestack,-1);
  445.  
  446.     /* now parse the script */
  447.  
  448.     error_count = 0;
  449.     if (yyparse() || error_count) {
  450.     if (minus_c)
  451.         fatal("%s had compilation errors.\n", origfilename);
  452.     else {
  453.         fatal("Execution of %s aborted due to compilation errors.\n",
  454.         origfilename);
  455.     }
  456.     }
  457.  
  458.     New(50,loop_stack,128,struct loop);
  459. #ifdef DEBUGGING
  460.     if (debug) {
  461.     New(51,debname,128,char);
  462.     New(52,debdelim,128,char);
  463.     }
  464. #endif
  465.     curstash = defstash;
  466.  
  467.     preprocess = FALSE;
  468.     if (e_fp) {
  469.     e_fp = Nullfp;
  470.     (void)UNLINK(e_tmpname);
  471.     }
  472.  
  473.     /* initialize everything that won't change if we undump */
  474.  
  475.     if ((sigstab = stabent("SIG",allstabs)) != Nullstab) {
  476.     sigstab->str_pok |= SP_MULTI;
  477.     (void)hadd(sigstab);
  478.     }
  479.  
  480.     magicalize("!#?^~=-%123456789.+&*,\\/[|`':>\024");
  481.     userinit();        /* in case linked C routines want magical variables */
  482.  
  483.     amperstab = stabent("&",allstabs);
  484.     leftstab = stabent("`",allstabs);
  485.     rightstab = stabent("'",allstabs);
  486.     sawampersand = (amperstab || leftstab || rightstab);
  487.     if ((tmpstab = stabent(":",allstabs)) != Nullstab)
  488.     str_set(STAB_STR(tmpstab),chopset);
  489.     if ((tmpstab = stabent("\024",allstabs)) != Nullstab)
  490.     os_starttime(&basetime);
  491.  
  492.     /* these aren't necessarily magical */
  493.     if ((tmpstab = stabent(";",allstabs)) != Nullstab)
  494.     str_set(STAB_STR(tmpstab),"\034");
  495.     if ((tmpstab = stabent("]",allstabs)) != Nullstab) {
  496.     str = STAB_STR(tmpstab);
  497.     str_set(str,rcsid);
  498.     str->str_u.str_nval = atof(patchlevel);
  499.     str->str_nok = 1;
  500.     }
  501.     str_nset(stab_val(stabent("\"", TRUE)), " ", 1);
  502.  
  503.     stdinstab = stabent("STDIN",TRUE);
  504.     stdinstab->str_pok |= SP_MULTI;
  505.     stab_io(stdinstab) = stio_new();
  506.     stab_io(stdinstab)->ifp = stdin;
  507.     stab_io(stdinstab)->type = '-';
  508.     tmpstab = stabent("stdin",TRUE);
  509.     stab_io(tmpstab) = stab_io(stdinstab);
  510.     tmpstab->str_pok |= SP_MULTI;
  511.  
  512.     tmpstab = stabent("STDOUT",TRUE);
  513.     tmpstab->str_pok |= SP_MULTI;
  514.     stab_io(tmpstab) = stio_new();
  515.     stab_io(tmpstab)->ofp = stab_io(tmpstab)->ifp = stdout;
  516.     stab_io(tmpstab)->type = '-';
  517.     defoutstab = tmpstab;
  518.     tmpstab = stabent("stdout",TRUE);
  519.     stab_io(tmpstab) = stab_io(defoutstab);
  520.     tmpstab->str_pok |= SP_MULTI;
  521.  
  522.     curoutstab = stabent("STDERR",TRUE);
  523.     curoutstab->str_pok |= SP_MULTI;
  524.     stab_io(curoutstab) = stio_new();
  525.     stab_io(curoutstab)->ofp = stab_io(curoutstab)->ifp = stderr;
  526.     stab_io(curoutstab)->type = '-';
  527.     tmpstab = stabent("stderr",TRUE);
  528.     stab_io(tmpstab) = stab_io(curoutstab);
  529.     tmpstab->str_pok |= SP_MULTI;
  530.     curoutstab = defoutstab;        /* switch back to STDOUT */
  531.  
  532.     statname = Str_new(66,0);        /* last filename we did stat on */
  533.  
  534.     err_no = 0;                /* Clear the error record */
  535.     strcpy(err_mess, "No error");
  536.  
  537.     argc--,argv++;    /* skip name of script */
  538.     if (doswitches) {
  539.     for (; argc > 0 && **argv == '-'; argc--,argv++) {
  540.         if (argv[0][1] == '-') {
  541.         argc--,argv++;
  542.         break;
  543.         }
  544.         str_numset(stab_val(stabent(argv[0]+1,TRUE)),(double)1.0);
  545.     }
  546.     }
  547. #ifdef TAINT
  548.     tainted = 1;
  549. #endif
  550.     if ((tmpstab = stabent("0",allstabs)) != Nullstab)
  551.     str_set(stab_val(tmpstab),origfilename);
  552.     if ((argvstab = stabent("ARGV",allstabs)) != Nullstab) {
  553.     argvstab->str_pok |= SP_MULTI;
  554.     (void)aadd(argvstab);
  555.     aclear(stab_array(argvstab));
  556.     for (; argc > 0; argc--,argv++) {
  557.         (void)apush(stab_array(argvstab),str_make(argv[0],0));
  558.     }
  559.     }
  560.  
  561. #ifdef TAINT
  562.     (void) stabent("ENV",TRUE);        /* must test PATH and IFS */
  563. #endif
  564.  
  565.     if ((envstab = stabent("ENV",allstabs)) != Nullstab) {
  566.     envstab->str_pok |= SP_MULTI;
  567.     (void)hadd(envstab);
  568.     hclear(stab_hash(envstab), FALSE);
  569.     for (s = getenvar("*",&val); s; s = getenvar(0,&val)) {
  570.         int len = strlen(s);
  571.         str = str_make(val,0);
  572.         str_magic(str, envstab, 'E', s, len);
  573.         (void)hstore(stab_hash(envstab), s, len, str, 0);
  574.     }
  575.     }
  576.  
  577. #ifdef TAINT
  578.     tainted = 0;
  579. #endif
  580.  
  581.     if ((tmpstab = stabent("<",allstabs)) != Nullstab)
  582.     str_set(STAB_STR(tmpstab),getcwd(1,0));
  583.  
  584.     if (dowarn) {
  585.     stab_check('A','Z');
  586.     stab_check('a','z');
  587.     }
  588.  
  589.     if (setjmp(top_env))    /* sets goto_targ on longjump */
  590.     loop_ptr = -1;        /* start label stack again */
  591.  
  592. #ifdef DEBUGGING
  593.     if (debug & 1024)
  594.     dump_all();
  595.     if (debug)
  596.     fprintf(stderr,"\nEXECUTING...\n\n");
  597. #endif
  598.  
  599.     if (minus_c) {
  600.     fprintf(stderr,"%s syntax OK\n", origfilename);
  601.     exit(0);
  602.     }
  603.  
  604.     /* do it */
  605.  
  606.     (void) cmd_exec(main_root,G_SCALAR,-1);
  607.  
  608.     if (goto_targ)
  609.     fatal("Can't find label \"%s\"--aborting",goto_targ);
  610.  
  611.     return 0;
  612. }
  613.  
  614. void
  615. magicalize(list)
  616. register char *list;
  617. {
  618.     char sym[2];
  619.  
  620.     sym[1] = '\0';
  621.     while ((*sym = *list++) != 0)
  622.     magicname(sym, Nullch, 0);
  623. }
  624.  
  625. void
  626. magicname(sym,name,namlen)
  627. char *sym;
  628. char *name;
  629. int namlen;
  630. {
  631.     register STAB *stab;
  632.  
  633.     if ((stab = stabent(sym,allstabs)) != Nullstab) {
  634.     stab_flags(stab) = SF_VMAGIC;
  635.     str_magic(stab_val(stab), stab, 0, name, namlen);
  636.     }
  637. }
  638.  
  639. /* this routine is in perly.c by virtue of being sort of an alternate main() */
  640.  
  641. int
  642. do_eval(str,optype,stash,gimme,arglast)
  643. STR *str;
  644. int optype;
  645. HASH *stash;
  646. int gimme;
  647. int *arglast;
  648. {
  649.     STR **st = stack->ary_array;
  650.     int retval;
  651.     CMD *myroot;
  652.     ARRAY *ar;
  653.     int i;
  654.     CMD * VOLATILE oldcurcmd = curcmd;
  655.     VOLATILE int oldtmps_base = tmps_base;
  656.     VOLATILE int oldsave = savestack->ary_fill;
  657.     VOLATILE int oldperldb = perldb;
  658.     SPAT * VOLATILE oldspat = curspat;
  659.     static char *last_eval = Nullch;
  660.     static CMD *last_root = Nullcmd;
  661.     VOLATILE int sp = arglast[0];
  662.     char *specfilename;
  663.     char *tmpfilename;
  664.  
  665.     tmps_base = tmps_max;
  666.     if (curstash != stash) {
  667.     (void)savehptr(&curstash);
  668.     curstash = stash;
  669.     }
  670.     str_set(stab_val(stabent("@",TRUE)),"");
  671.     if (curcmd->c_line == 0)        /* don't debug debugger... */
  672.     perldb = FALSE;
  673.     curcmd = &compiling;
  674.     if (optype == O_EVAL) {        /* normal eval */
  675.     curcmd->c_filestab = fstab("(eval)");
  676.     curcmd->c_line = 1;
  677.     str_sset(linestr,str);
  678.     str_cat(linestr,";");        /* be kind to them */
  679.     }
  680.     else {
  681.     if (last_root && !in_eval) {
  682.         Safefree(last_eval);
  683.         cmd_free(last_root);
  684.         last_root = Nullcmd;
  685.     }
  686.     specfilename = str_get(str);
  687.     str_set(linestr,"");
  688.     if (optype == O_REQUIRE && &str_undef !=
  689.       hfetch(stab_hash(incstab), specfilename, strlen(specfilename), 0)) {
  690.         curcmd = oldcurcmd;
  691.         tmps_base = oldtmps_base;
  692.         st[++sp] = &str_yes;
  693.         perldb = oldperldb;
  694.         return sp;
  695.     }
  696.     tmpfilename = savestr(specfilename);
  697.     if (index("$%&\\@", *tmpfilename))
  698.         rsfp = fopen(tmpfilename,"r");
  699.     else {
  700.         ar = stab_array(incstab);
  701.         for (i = 0; i <= ar->ary_fill; i++) {
  702.         (void)sprintf(buf,"%s.%s",
  703.           str_get(afetch(ar,i,TRUE)), specfilename);
  704.         rsfp = fopen(buf,"r");
  705.         if (rsfp) {
  706.             char *s = buf;
  707.  
  708.             if (*s == '@' && s[1] == '.')
  709.             s += 2;
  710.             Safefree(tmpfilename);
  711.             tmpfilename = savestr(s);
  712.             break;
  713.         }
  714.         }
  715.     }
  716.     curcmd->c_filestab = fstab(tmpfilename);
  717.     Safefree(tmpfilename);
  718.     if (!rsfp) {
  719.         curcmd = oldcurcmd;
  720.         tmps_base = oldtmps_base;
  721.         if (optype == O_REQUIRE) {
  722.         sprintf(tokenbuf,"Can't locate %s in @INC", specfilename);
  723.         fatal("%s",tokenbuf);
  724.         }
  725.         if (gimme != G_ARRAY)
  726.         st[++sp] = &str_undef;
  727.         perldb = oldperldb;
  728.         return sp;
  729.     }
  730.     curcmd->c_line = 0;
  731.     }
  732.     in_eval++;
  733.     oldoldbufptr = oldbufptr = bufptr = str_get(linestr);
  734.     bufend = bufptr + linestr->str_cur;
  735.     if (++loop_ptr >= loop_max) {
  736.     loop_max += 128;
  737.     Renew(loop_stack, loop_max, struct loop);
  738.     }
  739.     loop_stack[loop_ptr].loop_label = "_EVAL_";
  740.     loop_stack[loop_ptr].loop_sp = sp;
  741. #ifdef DEBUGGING
  742.     if (debug & 4) {
  743.     deb("(Pushing label #%d _EVAL_)\n", loop_ptr);
  744.     }
  745. #endif
  746.     if (setjmp(loop_stack[loop_ptr].loop_env)) {
  747.     retval = 1;
  748.     last_root = Nullcmd;
  749.     }
  750.     else {
  751.     error_count = 0;
  752.     if (rsfp) {
  753.         retval = yyparse();
  754.         retval |= error_count;
  755.     }
  756.     else if (last_root && *bufptr == *last_eval && strEQ(bufptr,last_eval)){
  757.         retval = 0;
  758.         eval_root = last_root;    /* no point in reparsing */
  759.     }
  760.     else if (in_eval == 1) {
  761.         if (last_root) {
  762.         Safefree(last_eval);
  763.         cmd_free(last_root);
  764.         }
  765.         last_eval = savestr(bufptr);
  766.         last_root = Nullcmd;
  767.         retval = yyparse();
  768.         retval |= error_count;
  769.         if (!retval)
  770.         last_root = eval_root;
  771.     }
  772.     else
  773.         retval = yyparse();
  774.     }
  775.     myroot = eval_root;        /* in case cmd_exec does another eval! */
  776.  
  777.     if (retval) {
  778.     st = stack->ary_array;
  779.     sp = arglast[0];
  780.     if (gimme != G_ARRAY)
  781.         st[++sp] = &str_undef;
  782.     last_root = Nullcmd;    /* can't free on error, for some reason */
  783.     if (rsfp) {
  784.         fclose(rsfp);
  785.         rsfp = 0;
  786.     }
  787.     }
  788.     else {
  789.     sp = cmd_exec(eval_root,gimme,sp);
  790.     st = stack->ary_array;
  791.     for (i = arglast[0] + 1; i <= sp; i++)
  792.         st[i] = str_static(st[i]);
  793.                 /* if we don't save result, free zaps it */
  794.     if (in_eval != 1 && myroot != last_root)
  795.         cmd_free(myroot);
  796.     }
  797.  
  798.     perldb = oldperldb;
  799.     in_eval--;
  800. #ifdef DEBUGGING
  801.     if (debug & 4) {
  802.     char *tmps = loop_stack[loop_ptr].loop_label;
  803.     deb("(Popping label #%d %s)\n",loop_ptr,
  804.         tmps ? tmps : "" );
  805.     }
  806. #endif
  807.     loop_ptr--;
  808.     tmps_base = oldtmps_base;
  809.     curspat = oldspat;
  810.     if (savestack->ary_fill > oldsave)    /* let them use local() */
  811.     restorelist(oldsave);
  812.  
  813.     if (optype != O_EVAL) {
  814.     if (retval) {
  815.         if (optype == O_REQUIRE)
  816.         fatal("%s", str_get(stab_val(stabent("@",TRUE))));
  817.     }
  818.     else {
  819.         curcmd = oldcurcmd;
  820.         if (gimme == G_SCALAR ? str_true(st[sp]) : sp > arglast[0]) {
  821.         (void)hstore(stab_hash(incstab), specfilename,
  822.           strlen(specfilename), str_smake(stab_val(curcmd->c_filestab)),
  823.               0 );
  824.         }
  825.         else if (optype == O_REQUIRE)
  826.         fatal("%s did not return a true value", specfilename);
  827.     }
  828.     }
  829.     curcmd = oldcurcmd;
  830.     return sp;
  831. }
  832.  
  833. /* This routine handles any switches that can be given during run */
  834.  
  835. static char *
  836. moreswitches(s)
  837. char *s;
  838. {
  839.     switch (*s) {
  840.     case '0':
  841.     record_separator = 0;
  842.     if (s[1] == '0' && !isdigit(s[2]))
  843.         rslen = 0;
  844.     while (*s >= '0' && *s <= '7') {
  845.         record_separator <<= 3;
  846.         record_separator += *s++ & 7;
  847.     }
  848.     return s;
  849.     case 'a':
  850.     minus_a = TRUE;
  851.     s++;
  852.     return s;
  853.     case 'c':
  854.     minus_c = TRUE;
  855.     s++;
  856.     return s;
  857.     case 'd':
  858. #ifdef TAINT
  859.     if (euid != uid || egid != gid)
  860.         fatal("No -d allowed in setuid scripts");
  861. #endif
  862.     perldb = TRUE;
  863.     s++;
  864.     return s;
  865.     case 'D':
  866. #ifdef DEBUGGING
  867. #ifdef TAINT
  868.     if (euid != uid || egid != gid)
  869.         fatal("No -D allowed in setuid scripts");
  870. #endif
  871.     debug = atoi(s+1);
  872. #else
  873.     warn("Recompile perl with -DDEBUGGING to use -D switch\n");
  874. #endif
  875.     break;
  876.     case 'i':
  877.     inplace = savestr(s+1);
  878.     for (s = inplace; *s && !isspace(*s); s++) ;
  879.     *s = '\0';
  880.     argvoutstab = stabent("ARGVOUT",TRUE);
  881.     break;
  882.     case 'I':
  883. #ifdef TAINT
  884.     if (euid != uid || egid != gid)
  885.         fatal("No -I allowed in setuid scripts");
  886. #endif
  887.     if (*++s) {
  888.         (void)apush(stab_array(incstab),str_make(s,0));
  889.     }
  890.     else
  891.         fatal("No space allowed after -I");
  892.     break;
  893.     case 'n':
  894.     minus_n = TRUE;
  895.     s++;
  896.     return s;
  897.     case 'p':
  898.     minus_p = TRUE;
  899.     s++;
  900.     return s;
  901.     case 'u':
  902.     /* do_undump = TRUE; */
  903.     s++;
  904.     return s;
  905.     case 'U':
  906.     unsafe = TRUE;
  907.     s++;
  908.     return s;
  909.     case 'v':
  910.     fputs("\nThis is perl, version 3.0\n\n",stdout);
  911.     fputs(rcsid,stdout);
  912.     fputs("\nCopyright (c) 1989, 1990, Larry Wall\n",stdout);
  913.     fputs("Archimedes port Copyright (c) 1990, Paul Moore\n", stdout);
  914.     fputs("\n\
  915. Perl may be copied only under the terms of the GNU General Public License,\n\
  916. a copy of which can be found with the Perl 3.0 distribution kit.\n",stdout);
  917.     exit(0);
  918.     case 'w':
  919.     dowarn = TRUE;
  920.     s++;
  921.     return s;
  922.     case ' ':
  923.     case '\n':
  924.     case '\t':
  925.     break;
  926.     default:
  927.     fatal("Switch meaningless after -x: -%s",s);
  928.     }
  929.     return Nullch;
  930. }
  931.