home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / msdos / perl386 / perl.c < prev    next >
Encoding:
C/C++ Source or Header  |  1993-07-21  |  38.8 KB  |  1,469 lines
  1. char rcsid[] = "$RCSfile: perl.c,v $$Revision: 4.0.1.8 $$Date: 1993/02/05 19:39:30 $\nPatch level: ###\n";
  2. /*
  3.  *    Copyright (c) 1991, 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.  * $Log: perl.c,v $
  9.  * Revision 4.0.1.8  1993/02/05  19:39:30  lwall
  10.  * patch36: the taintanyway code wasn't tainting anyway
  11.  * patch36: Malformed cmd links core dump apparently fixed
  12.  *
  13.  * Revision 4.0.1.7  92/06/08  14:50:39  lwall
  14.  * patch20: PERLLIB now supports multiple directories
  15.  * patch20: running taintperl explicitly now does checks even if $< == $>
  16.  * patch20: -e 'cmd' no longer fails silently if /tmp runs out of space
  17.  * patch20: perl -P now uses location of sed determined by Configure
  18.  * patch20: form feed for formats is now specifiable via $^L
  19.  * patch20: paragraph mode now skips extra newlines automatically
  20.  * patch20: eval "1 #comment" didn't work
  21.  * patch20: couldn't require . files
  22.  * patch20: semantic compilation errors didn't abort execution
  23.  * 
  24.  * Revision 4.0.1.6  91/11/11  16:38:45  lwall
  25.  * patch19: default arg for shift was wrong after first subroutine definition
  26.  * patch19: op/regexp.t failed from missing arg to bcmp()
  27.  * 
  28.  * Revision 4.0.1.5  91/11/05  18:03:32  lwall
  29.  * patch11: random cleanup
  30.  * patch11: $0 was being truncated at times
  31.  * patch11: cppstdin now installed outside of source directory
  32.  * patch11: -P didn't allow use of #elif or #undef
  33.  * patch11: prepared for ctype implementations that don't define isascii()
  34.  * patch11: added eval {}
  35.  * patch11: eval confused by string containing null
  36.  * 
  37.  * Revision 4.0.1.4  91/06/10  01:23:07  lwall
  38.  * patch10: perl -v printed incorrect copyright notice
  39.  * 
  40.  * Revision 4.0.1.3  91/06/07  11:40:18  lwall
  41.  * patch4: changed old $^P to $^X
  42.  * 
  43.  * Revision 4.0.1.2  91/06/07  11:26:16  lwall
  44.  * patch4: new copyright notice
  45.  * patch4: added $^P variable to control calling of perldb routines
  46.  * patch4: added $^F variable to specify maximum system fd, default 2
  47.  * patch4: debugger lost track of lines in eval
  48.  * 
  49.  * Revision 4.0.1.1  91/04/11  17:49:05  lwall
  50.  * patch1: fixed undefined environ problem
  51.  * 
  52.  * Revision 4.0  91/03/20  01:37:44  lwall
  53.  * 4.0 baseline.
  54.  * 
  55.  */
  56.  
  57. /*SUPPRESS 560*/
  58.  
  59. #include "EXTERN.h"
  60. #include "perl.h"
  61. #include "perly.h"
  62. #include "patchlevel.h"
  63.  
  64. char *getenv();
  65.  
  66. #ifdef IAMSUID
  67. #ifndef DOSUID
  68. #define DOSUID
  69. #endif
  70. #endif
  71.  
  72. #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
  73. #ifdef DOSUID
  74. #undef DOSUID
  75. #endif
  76. #endif
  77.  
  78. static char* moreswitches();
  79. static void incpush();
  80. static char* cddir;
  81. static bool minus_c;
  82. static char patchlevel[6];
  83. static char *nrs = "\n";
  84. static int nrschar = '\n';      /* final char of rs, or 0777 if none */
  85. static int nrslen = 1;
  86.  
  87. main(argc,argv,env)
  88. #ifdef DJGPP
  89. int argc;
  90. char **argv;
  91. #else
  92. register int argc;
  93. register char **argv;
  94. #endif /* DJGPP */
  95. register char **env;
  96. {
  97.     register STR *str;
  98.     register char *s;
  99.     char *scriptname;
  100.     char *getenv();
  101.     bool dosearch = FALSE;
  102. #ifdef DOSUID
  103.     char *validarg = "";
  104. #endif
  105.  
  106. #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
  107. #ifdef IAMSUID
  108. #undef IAMSUID
  109.     fatal("suidperl is no longer needed since the kernel can now execute\n\
  110. setuid perl scripts securely.\n");
  111. #endif
  112. #endif
  113.  
  114.     origargv = argv;
  115.     origargc = argc;
  116.     origenviron = environ;
  117.     uid = (int)getuid();
  118.     euid = (int)geteuid();
  119.     gid = (int)getgid();
  120.     egid = (int)getegid();
  121.     sprintf(patchlevel,"%3.3s%2.2d", index(rcsid,'4'), PATCHLEVEL);
  122. #ifdef MSDOS
  123.     /*
  124.      * There is no way we can refer to them from Perl so close them to save
  125.      * space.  The other alternative would be to provide STDAUX and STDPRN
  126.      * filehandles.
  127.      */
  128. #ifndef DJGPP
  129.     (void)fclose(stdaux);
  130.     (void)fclose(stdprn);
  131. #endif /* !DJGPP */
  132. #endif
  133.     if (do_undump) {
  134.     origfilename = savestr(argv[0]);
  135.     do_undump = 0;
  136.     loop_ptr = -1;        /* start label stack again */
  137.     goto just_doit;
  138.     }
  139. #ifdef TAINT
  140. #ifndef DOSUID
  141.     if (uid == euid && gid == egid)
  142.     taintanyway = TRUE;        /* running taintperl explicitly */
  143. #endif
  144. #endif
  145.     (void)sprintf(index(rcsid,'#'), "%d\n", PATCHLEVEL);
  146.     linestr = Str_new(65,80);
  147.     str_nset(linestr,"",0);
  148.     str = str_make("",0);        /* first used for -I flags */
  149.     curstash = defstash = hnew(0);
  150.     curstname = str_make("main",4);
  151.     stab_xhash(stabent("_main",TRUE)) = defstash;
  152.     defstash->tbl_name = "main";
  153.     incstab = hadd(aadd(stabent("INC",TRUE)));
  154.     incstab->str_pok |= SP_MULTI;
  155.     for (argc--,argv++; argc > 0; argc--,argv++) {
  156.     if (argv[0][0] != '-' || !argv[0][1])
  157.         break;
  158. #ifdef DOSUID
  159.     if (*validarg)
  160.     validarg = " PHOOEY ";
  161.     else
  162.     validarg = argv[0];
  163. #endif
  164.     s = argv[0]+1;
  165.       reswitch:
  166.     switch (*s) {
  167.     case '0':
  168.     case 'a':
  169.     case 'c':
  170.     case 'd':
  171.     case 'D':
  172.     case 'i':
  173.     case 'l':
  174.     case 'n':
  175.     case 'p':
  176.     case 'u':
  177.     case 'U':
  178.     case 'v':
  179.     case 'w':
  180.         if (s = moreswitches(s))
  181.         goto reswitch;
  182.         break;
  183.  
  184.     case 'e':
  185. #ifdef TAINT
  186.         if (euid != uid || egid != gid)
  187.         fatal("No -e allowed in setuid scripts");
  188. #endif
  189.         if (!e_fp) {
  190.             e_tmpname = savestr(TMPPATH);
  191.         (void)mktemp(e_tmpname);
  192.         if (!*e_tmpname)
  193.             fatal("Can't mktemp()");
  194.         e_fp = fopen(e_tmpname,"w");
  195.         if (!e_fp)
  196.             fatal("Cannot open temporary file");
  197.         }
  198.         if (argv[1]) {
  199.         fputs(argv[1],e_fp);
  200.         argc--,argv++;
  201.         }
  202.         (void)putc('\n', e_fp);
  203.         break;
  204.     case 'I':
  205. #ifdef TAINT
  206.         if (euid != uid || egid != gid)
  207.         fatal("No -I allowed in setuid scripts");
  208. #endif
  209.         str_cat(str,"-");
  210.         str_cat(str,s);
  211.         str_cat(str," ");
  212.         if (*++s) {
  213.         (void)apush(stab_array(incstab),str_make(s,0));
  214.         }
  215.         else if (argv[1]) {
  216.         (void)apush(stab_array(incstab),str_make(argv[1],0));
  217.         str_cat(str,argv[1]);
  218.         argc--,argv++;
  219.         str_cat(str," ");
  220.         }
  221.         break;
  222.     case 'P':
  223. #ifdef TAINT
  224.         if (euid != uid || egid != gid)
  225.         fatal("No -P allowed in setuid scripts");
  226. #endif
  227.         preprocess = TRUE;
  228.         s++;
  229.         goto reswitch;
  230.     case 's':
  231. #ifdef TAINT
  232.         if (euid != uid || egid != gid)
  233.         fatal("No -s allowed in setuid scripts");
  234. #endif
  235.         doswitches = TRUE;
  236.         s++;
  237.         goto reswitch;
  238.     case 'S':
  239. #ifdef TAINT
  240.         if (euid != uid || egid != gid)
  241.         fatal("No -S allowed in setuid scripts");
  242. #endif
  243.         dosearch = TRUE;
  244.         s++;
  245.         goto reswitch;
  246.     case 'x':
  247.         doextract = TRUE;
  248.         s++;
  249.         if (*s)
  250.         cddir = savestr(s);
  251.         break;
  252.     case '-':
  253.         argc--,argv++;
  254.         goto switch_end;
  255.     case 0:
  256.         break;
  257.     default:
  258.         fatal("Unrecognized switch: -%s",s);
  259.     }
  260.     }
  261.   switch_end:
  262.     scriptname = argv[0];
  263.     if (e_fp) {
  264.     if (fflush(e_fp) || ferror(e_fp) || fclose(e_fp))
  265.         fatal("Can't write to temp file for -e: %s", strerror(errno));
  266.     argc++,argv--;
  267.     scriptname = e_tmpname;
  268.     }
  269.  
  270. #ifdef DOSISH
  271. #define PERLLIB_SEP ';'
  272. #else
  273. #define PERLLIB_SEP ':'
  274. #endif
  275. #ifndef TAINT        /* Can't allow arbitrary PERLLIB in setuid script */
  276.     incpush(getenv("PERLLIB"));
  277. #endif /* TAINT */
  278.  
  279. #ifndef PRIVLIB
  280. #define PRIVLIB "/usr/local/lib/perl"
  281. #endif
  282.     incpush(PRIVLIB);
  283.     (void)apush(stab_array(incstab),str_make(".",1));
  284.  
  285.     str_set(&str_no,No);
  286.     str_set(&str_yes,Yes);
  287.  
  288.     /* open script */
  289.  
  290.     if (scriptname == Nullch)
  291. #ifdef MSDOS
  292.     {
  293.     if ( isatty(fileno(stdin)) )
  294.       moreswitches("v");
  295.     scriptname = "-";
  296.     }
  297. #else
  298.     scriptname = "-";
  299. #endif
  300.     if (dosearch && !index(scriptname, '/') && (s = getenv("PATH"))) {
  301.     char *xfound = Nullch, *xfailed = Nullch;
  302.     int len;
  303.  
  304.     bufend = s + strlen(s);
  305.     while (*s) {
  306. #ifndef DOSISH
  307.         s = cpytill(tokenbuf,s,bufend,':',&len);
  308. #else
  309. #ifdef atarist
  310.         for (len = 0; *s && *s != ',' && *s != ';'; tokenbuf[len++] = *s++);
  311.         tokenbuf[len] = '\0';
  312. #else
  313.         for (len = 0; *s && *s != ';'; tokenbuf[len++] = *s++);
  314.         tokenbuf[len] = '\0';
  315. #endif
  316. #endif
  317.         if (*s)
  318.         s++;
  319. #ifndef DOSISH
  320.         if (len && tokenbuf[len-1] != '/')
  321. #else
  322. #ifdef atarist
  323.         if (len && ((tokenbuf[len-1] != '\\') && (tokenbuf[len-1] != '/')))
  324. #else
  325.         if (len && tokenbuf[len-1] != '\\')
  326. #endif
  327. #endif
  328.         (void)strcat(tokenbuf+len,"/");
  329.         (void)strcat(tokenbuf+len,scriptname);
  330. #ifdef DEBUGGING
  331.         if (debug & 1)
  332.         fprintf(stderr,"Looking for %s\n",tokenbuf);
  333. #endif
  334.         if (stat(tokenbuf,&statbuf) < 0)        /* not there? */
  335.         continue;
  336.         if (S_ISREG(statbuf.st_mode)
  337.          && cando(S_IRUSR,TRUE,&statbuf) && cando(S_IXUSR,TRUE,&statbuf)) {
  338.         xfound = tokenbuf;              /* bingo! */
  339.         break;
  340.         }
  341.         if (!xfailed)
  342.         xfailed = savestr(tokenbuf);
  343.     }
  344.     if (!xfound)
  345.         fatal("Can't execute %s", xfailed ? xfailed : scriptname );
  346.     if (xfailed)
  347.         Safefree(xfailed);
  348.     scriptname = savestr(xfound);
  349.     }
  350.  
  351.     fdpid = anew(Nullstab);    /* for remembering popen pids by fd */
  352.     pidstatus = hnew(COEFFSIZE);/* for remembering status of dead pids */
  353.  
  354.     origfilename = savestr(scriptname);
  355.     curcmd->c_filestab = fstab(origfilename);
  356.     if (strEQ(origfilename,"-"))
  357.     scriptname = "";
  358.     if (preprocess) {
  359.     char *cpp = CPPSTDIN;
  360.  
  361.     if (strEQ(cpp,"cppstdin"))
  362.         sprintf(tokenbuf, "%s/%s", SCRIPTDIR, cpp);
  363.     else
  364.         sprintf(tokenbuf, "%s", cpp);
  365.     str_cat(str,"-I");
  366.     str_cat(str,PRIVLIB);
  367. #ifdef MSDOS
  368.     (void)sprintf(buf, "\
  369. sed %s -e \"/^[^#]/b\" \
  370.  -e \"/^#[     ]*include[     ]/b\" \
  371.  -e \"/^#[     ]*define[     ]/b\" \
  372.  -e \"/^#[     ]*if[     ]/b\" \
  373.  -e \"/^#[     ]*ifdef[     ]/b\" \
  374.  -e \"/^#[     ]*ifndef[     ]/b\" \
  375.  -e \"/^#[     ]*else/b\" \
  376.  -e \"/^#[     ]*elif[     ]/b\" \
  377.  -e \"/^#[     ]*undef[     ]/b\" \
  378.  -e \"/^#[     ]*endif/b\" \
  379.  -e \"s/^#.*//\" \
  380.  %s | %s -C %s %s",
  381.       (doextract ? "-e \"1,/^#/d\n\"" : ""),
  382. #else
  383.     (void)sprintf(buf, "\
  384. %s %s -e '/^[^#]/b' \
  385.  -e '/^#[     ]*include[     ]/b' \
  386.  -e '/^#[     ]*define[     ]/b' \
  387.  -e '/^#[     ]*if[     ]/b' \
  388.  -e '/^#[     ]*ifdef[     ]/b' \
  389.  -e '/^#[     ]*ifndef[     ]/b' \
  390.  -e '/^#[     ]*else/b' \
  391.  -e '/^#[     ]*elif[     ]/b' \
  392.  -e '/^#[     ]*undef[     ]/b' \
  393.  -e '/^#[     ]*endif/b' \
  394.  -e 's/^[     ]*#.*//' \
  395.  %s | %s -C %s %s",
  396. #ifdef LOC_SED
  397.       LOC_SED,
  398. #else
  399.       "sed",
  400. #endif
  401.       (doextract ? "-e '1,/^#/d\n'" : ""),
  402. #endif
  403.       scriptname, tokenbuf, str_get(str), CPPMINUS);
  404. #ifdef DEBUGGING
  405.     if (debug & 64) {
  406.         fputs(buf,stderr);
  407.         fputs("\n",stderr);
  408.     }
  409. #endif
  410.     doextract = FALSE;
  411. #ifdef IAMSUID                /* actually, this is caught earlier */
  412.     if (euid != uid && !euid) {    /* if running suidperl */
  413. #ifdef HAS_SETEUID
  414.         (void)seteuid(uid);        /* musn't stay setuid root */
  415. #else
  416. #ifdef HAS_SETREUID
  417.         (void)setreuid(-1, uid);
  418. #else
  419.         setuid(uid);
  420. #endif
  421. #endif
  422.         if (geteuid() != uid)
  423.         fatal("Can't do seteuid!\n");
  424.     }
  425. #endif /* IAMSUID */
  426.     rsfp = mypopen(buf,"r");
  427.     }
  428.     else if (!*scriptname) {
  429. #ifdef TAINT
  430.     if (euid != uid || egid != gid)
  431.         fatal("Can't take set-id script from stdin");
  432. #endif
  433.     rsfp = stdin;
  434.     }
  435.     else
  436.     rsfp = fopen(scriptname,"r");
  437.     if ((FILE*)rsfp == Nullfp) {
  438. #ifdef DOSUID
  439. #ifndef IAMSUID        /* in case script is not readable before setuid */
  440.     if (euid && stat(stab_val(curcmd->c_filestab)->str_ptr,&statbuf) >= 0 &&
  441.       statbuf.st_mode & (S_ISUID|S_ISGID)) {
  442.         (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
  443. #ifndef DJGPP
  444.         execv(buf, origargv);   /* try again */
  445. #endif /* !DJGPP */
  446.         fatal("Can't do setuid\n");
  447.     }
  448. #endif
  449. #endif
  450.     fatal("Can't open perl script \"%s\": %s\n",
  451.       stab_val(curcmd->c_filestab)->str_ptr, strerror(errno));
  452.     }
  453.     str_free(str);        /* free -I directories */
  454.     str = Nullstr;
  455.  
  456.     /* do we need to emulate setuid on scripts? */
  457.  
  458.     /* This code is for those BSD systems that have setuid #! scripts disabled
  459.      * in the kernel because of a security problem.  Merely defining DOSUID
  460.      * in perl will not fix that problem, but if you have disabled setuid
  461.      * scripts in the kernel, this will attempt to emulate setuid and setgid
  462.      * on scripts that have those now-otherwise-useless bits set.  The setuid
  463.      * root version must be called suidperl or sperlN.NNN.  If regular perl
  464.      * discovers that it has opened a setuid script, it calls suidperl with
  465.      * the same argv that it had.  If suidperl finds that the script it has
  466.      * just opened is NOT setuid root, it sets the effective uid back to the
  467.      * uid.  We don't just make perl setuid root because that loses the
  468.      * effective uid we had before invoking perl, if it was different from the
  469.      * uid.
  470.      *
  471.      * DOSUID must be defined in both perl and suidperl, and IAMSUID must
  472.      * be defined in suidperl only.  suidperl must be setuid root.  The
  473.      * Configure script will set this up for you if you want it.
  474.      *
  475.      * There is also the possibility of have a script which is running
  476.      * set-id due to a C wrapper.  We want to do the TAINT checks
  477.      * on these set-id scripts, but don't want to have the overhead of
  478.      * them in normal perl, and can't use suidperl because it will lose
  479.      * the effective uid info, so we have an additional non-setuid root
  480.      * version called taintperl or tperlN.NNN that just does the TAINT checks.
  481.      */
  482.  
  483. #ifdef DOSUID
  484.     if (fstat(fileno(rsfp),&statbuf) < 0)    /* normal stat is insecure */
  485.     fatal("Can't stat script \"%s\"",origfilename);
  486.     if (statbuf.st_mode & (S_ISUID|S_ISGID)) {
  487.     int len;
  488.  
  489. #ifdef IAMSUID
  490. #ifndef HAS_SETREUID
  491.     /* On this access check to make sure the directories are readable,
  492.      * there is actually a small window that the user could use to make
  493.      * filename point to an accessible directory.  So there is a faint
  494.      * chance that someone could execute a setuid script down in a
  495.      * non-accessible directory.  I don't know what to do about that.
  496.      * But I don't think it's too important.  The manual lies when
  497.      * it says access() is useful in setuid programs.
  498.      */
  499.     if (access(stab_val(curcmd->c_filestab)->str_ptr,1))    /*double check*/
  500.         fatal("Permission denied");
  501. #else
  502.     /* If we can swap euid and uid, then we can determine access rights
  503.      * with a simple stat of the file, and then compare device and
  504.      * inode to make sure we did stat() on the same file we opened.
  505.      * Then we just have to make sure he or she can execute it.
  506.      */
  507.     {
  508.         struct stat tmpstatbuf;
  509.  
  510.         if (setreuid(euid,uid) < 0 || getuid() != euid || geteuid() != uid)
  511.         fatal("Can't swap uid and euid");    /* really paranoid */
  512.         if (stat(stab_val(curcmd->c_filestab)->str_ptr,&tmpstatbuf) < 0)
  513.         fatal("Permission denied");    /* testing full pathname here */
  514.         if (tmpstatbuf.st_dev != statbuf.st_dev ||
  515.         tmpstatbuf.st_ino != statbuf.st_ino) {
  516.         (void)fclose(rsfp);
  517.         if (rsfp = mypopen("/bin/mail root","w")) {    /* heh, heh */
  518.             fprintf(rsfp,
  519. "User %d tried to run dev %d ino %d in place of dev %d ino %d!\n\
  520. (Filename of set-id script was %s, uid %d gid %d.)\n\nSincerely,\nperl\n",
  521.             uid,tmpstatbuf.st_dev, tmpstatbuf.st_ino,
  522.             statbuf.st_dev, statbuf.st_ino,
  523.             stab_val(curcmd->c_filestab)->str_ptr,
  524.             statbuf.st_uid, statbuf.st_gid);
  525.             (void)mypclose(rsfp);
  526.         }
  527.         fatal("Permission denied\n");
  528.         }
  529.         if (setreuid(uid,euid) < 0 || getuid() != uid || geteuid() != euid)
  530.         fatal("Can't reswap uid and euid");
  531.         if (!cando(S_IXUSR,FALSE,&statbuf))        /* can real uid exec? */
  532.         fatal("Permission denied\n");
  533.     }
  534. #endif /* HAS_SETREUID */
  535. #endif /* IAMSUID */
  536.  
  537.     if (!S_ISREG(statbuf.st_mode))
  538.         fatal("Permission denied");
  539.     if (statbuf.st_mode & S_IWOTH)
  540.         fatal("Setuid/gid script is writable by world");
  541.     doswitches = FALSE;        /* -s is insecure in suid */
  542.     curcmd->c_line++;
  543.     if (fgets(tokenbuf,sizeof tokenbuf, rsfp) == Nullch ||
  544.       strnNE(tokenbuf,"#!",2) )    /* required even on Sys V */
  545.         fatal("No #! line");
  546.     s = tokenbuf+2;
  547.     if (*s == ' ') s++;
  548.     while (!isSPACE(*s)) s++;
  549.     if (strnNE(s-4,"perl",4) && strnNE(s-9,"perl",4))  /* sanity check */
  550.         fatal("Not a perl script");
  551.     while (*s == ' ' || *s == '\t') s++;
  552.     /*
  553.      * #! arg must be what we saw above.  They can invoke it by
  554.      * mentioning suidperl explicitly, but they may not add any strange
  555.      * arguments beyond what #! says if they do invoke suidperl that way.
  556.      */
  557.     len = strlen(validarg);
  558.     if (strEQ(validarg," PHOOEY ") ||
  559.         strnNE(s,validarg,len) || !isSPACE(s[len]))
  560.         fatal("Args must match #! line");
  561.  
  562. #ifndef IAMSUID
  563.     if (euid != uid && (statbuf.st_mode & S_ISUID) &&
  564.         euid == statbuf.st_uid)
  565.         if (!do_undump)
  566.         fatal("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
  567. FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
  568. #endif /* IAMSUID */
  569.  
  570.     if (euid) {    /* oops, we're not the setuid root perl */
  571.         (void)fclose(rsfp);
  572. #ifndef IAMSUID
  573.         (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
  574. #ifndef DJGPP
  575.         execv(buf, origargv);   /* try again */
  576. #endif /* !DJGPP */
  577. #endif
  578.         fatal("Can't do setuid\n");
  579.     }
  580.  
  581.     if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) {
  582. #ifdef HAS_SETEGID
  583.         (void)setegid(statbuf.st_gid);
  584. #else
  585. #ifdef HAS_SETREGID
  586.         (void)setregid((GIDTYPE)-1,statbuf.st_gid);
  587. #else
  588.         setgid(statbuf.st_gid);
  589. #endif
  590. #endif
  591.         if (getegid() != statbuf.st_gid)
  592.         fatal("Can't do setegid!\n");
  593.     }
  594.     if (statbuf.st_mode & S_ISUID) {
  595.         if (statbuf.st_uid != euid)
  596. #ifdef HAS_SETEUID
  597.         (void)seteuid(statbuf.st_uid);    /* all that for this */
  598. #else
  599. #ifdef HAS_SETREUID
  600.         (void)setreuid((UIDTYPE)-1,statbuf.st_uid);
  601. #else
  602.         setuid(statbuf.st_uid);
  603. #endif
  604. #endif
  605.         if (geteuid() != statbuf.st_uid)
  606.         fatal("Can't do seteuid!\n");
  607.     }
  608.     else if (uid) {            /* oops, mustn't run as root */
  609. #ifdef HAS_SETEUID
  610.         (void)seteuid((UIDTYPE)uid);
  611. #else
  612. #ifdef HAS_SETREUID
  613.         (void)setreuid((UIDTYPE)-1,(UIDTYPE)uid);
  614. #else
  615.         setuid((UIDTYPE)uid);
  616. #endif
  617. #endif
  618.         if (geteuid() != uid)
  619.         fatal("Can't do seteuid!\n");
  620.     }
  621.     uid = (int)getuid();
  622.     euid = (int)geteuid();
  623.     gid = (int)getgid();
  624.     egid = (int)getegid();
  625.     if (!cando(S_IXUSR,TRUE,&statbuf))
  626.         fatal("Permission denied\n");    /* they can't do this */
  627.     }
  628. #ifdef IAMSUID
  629.     else if (preprocess)
  630.     fatal("-P not allowed for setuid/setgid script\n");
  631.     else
  632.     fatal("Script is not setuid/setgid in suidperl\n");
  633. #else
  634. #ifndef TAINT        /* we aren't taintperl or suidperl */
  635.     /* script has a wrapper--can't run suidperl or we lose euid */
  636.     else if (euid != uid || egid != gid) {
  637.     (void)fclose(rsfp);
  638.     (void)sprintf(buf, "%s/tperl%s", BIN, patchlevel);
  639. #ifndef DJGPP
  640.     execv(buf, origargv);   /* try again */
  641. #endif
  642.     fatal("Can't run setuid script with taint checks");
  643.     }
  644. #endif /* TAINT */
  645. #endif /* IAMSUID */
  646. #else /* !DOSUID */
  647. #ifndef TAINT        /* we aren't taintperl or suidperl */
  648.     if (euid != uid || egid != gid) {    /* (suidperl doesn't exist, in fact) */
  649. #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
  650.     fstat(fileno(rsfp),&statbuf);    /* may be either wrapped or real suid */
  651.     if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
  652.         ||
  653.         (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
  654.        )
  655.         if (!do_undump)
  656.         fatal("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
  657. FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
  658. #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
  659.     /* not set-id, must be wrapped */
  660.     (void)fclose(rsfp);
  661.     (void)sprintf(buf, "%s/tperl%s", BIN, patchlevel);
  662. #ifndef DJGPP
  663.     execv(buf, origargv);   /* try again */
  664. #endif
  665.     fatal("Can't run setuid script with taint checks");
  666.     }
  667. #endif /* TAINT */
  668. #endif /* DOSUID */
  669.  
  670. #if !defined(IAMSUID) && !defined(TAINT)
  671.  
  672.     /* skip forward in input to the real script? */
  673.  
  674.     while (doextract) {
  675.     if ((s = str_gets(linestr, rsfp, 0)) == Nullch)
  676.         fatal("No Perl script found in input\n");
  677.     if (*s == '#' && s[1] == '!' && instr(s,"perl")) {
  678.         ungetc('\n',rsfp);        /* to keep line count right */
  679.         doextract = FALSE;
  680.         if (s = instr(s,"perl -")) {
  681.         s += 6;
  682.         /*SUPPRESS 530*/
  683.         while (s = moreswitches(s)) ;
  684.         }
  685.         if (cddir && chdir(cddir) < 0)
  686.         fatal("Can't chdir to %s",cddir);
  687.     }
  688.     }
  689. #endif /* !defined(IAMSUID) && !defined(TAINT) */
  690.  
  691.     defstab = stabent("_",TRUE);
  692.  
  693.     subname = str_make("main",4);
  694.     if (perldb) {
  695.     debstash = hnew(0);
  696.     stab_xhash(stabent("_DB",TRUE)) = debstash;
  697.     curstash = debstash;
  698.     dbargs = stab_xarray(aadd((tmpstab = stabent("args",TRUE))));
  699.     tmpstab->str_pok |= SP_MULTI;
  700.     dbargs->ary_flags = 0;
  701.     DBstab = stabent("DB",TRUE);
  702.     DBstab->str_pok |= SP_MULTI;
  703.     DBline = stabent("dbline",TRUE);
  704.     DBline->str_pok |= SP_MULTI;
  705.     DBsub = hadd(tmpstab = stabent("sub",TRUE));
  706.     tmpstab->str_pok |= SP_MULTI;
  707.     DBsingle = stab_val((tmpstab = stabent("single",TRUE)));
  708.     tmpstab->str_pok |= SP_MULTI;
  709.     DBtrace = stab_val((tmpstab = stabent("trace",TRUE)));
  710.     tmpstab->str_pok |= SP_MULTI;
  711.     DBsignal = stab_val((tmpstab = stabent("signal",TRUE)));
  712.     tmpstab->str_pok |= SP_MULTI;
  713.     curstash = defstash;
  714.     }
  715.  
  716.     /* init tokener */
  717.  
  718.     bufend = bufptr = str_get(linestr);
  719.  
  720.     savestack = anew(Nullstab);        /* for saving non-local values */
  721.     stack = anew(Nullstab);        /* for saving non-local values */
  722.     stack->ary_flags = 0;        /* not a real array */
  723.     afill(stack,63); afill(stack,-1);    /* preextend stack */
  724.     afill(savestack,63); afill(savestack,-1);
  725.  
  726.     /* now parse the script */
  727.  
  728.     error_count = 0;
  729.     if (yyparse() || error_count) {
  730.     if (minus_c)
  731.         fatal("%s had compilation errors.\n", origfilename);
  732.     else {
  733.         fatal("Execution of %s aborted due to compilation errors.\n",
  734.         origfilename);
  735.     }
  736.     }
  737.  
  738.     New(50,loop_stack,128,struct loop);
  739. #ifdef DEBUGGING
  740.     if (debug) {
  741.     New(51,debname,128,char);
  742.     New(52,debdelim,128,char);
  743.     }
  744. #endif
  745.     curstash = defstash;
  746.  
  747.     preprocess = FALSE;
  748.     if (e_fp) {
  749.     e_fp = Nullfp;
  750.     (void)UNLINK(e_tmpname);
  751.     }
  752.  
  753.     /* initialize everything that won't change if we undump */
  754.  
  755.     if (sigstab = stabent("SIG",allstabs)) {
  756.     sigstab->str_pok |= SP_MULTI;
  757.     (void)hadd(sigstab);
  758.     }
  759.  
  760.     magicalize("!#?^~=-%.+&*()<>,\\/[|`':\004\t\020\024\027\006");
  761.     userinit();        /* in case linked C routines want magical variables */
  762.  
  763.     amperstab = stabent("&",allstabs);
  764.     leftstab = stabent("`",allstabs);
  765.     rightstab = stabent("'",allstabs);
  766.     sawampersand = (amperstab || leftstab || rightstab);
  767.     if (tmpstab = stabent(":",allstabs))
  768.     str_set(stab_val(tmpstab),chopset);
  769.     if (tmpstab = stabent("\024",allstabs))
  770.     time(&basetime);
  771.  
  772.     /* these aren't necessarily magical */
  773.     if (tmpstab = stabent("\014",allstabs)) {
  774.     str_set(stab_val(tmpstab),"\f");
  775.     formfeed = stab_val(tmpstab);
  776.     }
  777.     if (tmpstab = stabent(";",allstabs))
  778.     str_set(STAB_STR(tmpstab),"\034");
  779.     if (tmpstab = stabent("]",allstabs)) {
  780.     str = STAB_STR(tmpstab);
  781.     str_set(str,rcsid);
  782.     str->str_u.str_nval = atof(patchlevel);
  783.     str->str_nok = 1;
  784.     }
  785.     str_nset(stab_val(stabent("\"", TRUE)), " ", 1);
  786.  
  787.     stdinstab = stabent("STDIN",TRUE);
  788.     stdinstab->str_pok |= SP_MULTI;
  789.     if (!stab_io(stdinstab))
  790.     stab_io(stdinstab) = stio_new();
  791.     stab_io(stdinstab)->ifp = stdin;
  792.     tmpstab = stabent("stdin",TRUE);
  793.     stab_io(tmpstab) = stab_io(stdinstab);
  794.     tmpstab->str_pok |= SP_MULTI;
  795.  
  796.     tmpstab = stabent("STDOUT",TRUE);
  797.     tmpstab->str_pok |= SP_MULTI;
  798.     if (!stab_io(tmpstab))
  799.     stab_io(tmpstab) = stio_new();
  800.     stab_io(tmpstab)->ofp = stab_io(tmpstab)->ifp = stdout;
  801.     defoutstab = tmpstab;
  802.     tmpstab = stabent("stdout",TRUE);
  803.     stab_io(tmpstab) = stab_io(defoutstab);
  804.     tmpstab->str_pok |= SP_MULTI;
  805.  
  806.     curoutstab = stabent("STDERR",TRUE);
  807.     curoutstab->str_pok |= SP_MULTI;
  808.     if (!stab_io(curoutstab))
  809.     stab_io(curoutstab) = stio_new();
  810.     stab_io(curoutstab)->ofp = stab_io(curoutstab)->ifp = stderr;
  811.     tmpstab = stabent("stderr",TRUE);
  812.     stab_io(tmpstab) = stab_io(curoutstab);
  813.     tmpstab->str_pok |= SP_MULTI;
  814.     curoutstab = defoutstab;        /* switch back to STDOUT */
  815.  
  816.     statname = Str_new(66,0);        /* last filename we did stat on */
  817.  
  818.     /* now that script is parsed, we can modify record separator */
  819.  
  820.     rs = nrs;
  821.     rslen = nrslen;
  822.     rschar = nrschar;
  823.     rspara = (nrslen == 2);
  824.     str_nset(stab_val(stabent("/", TRUE)), rs, rslen);
  825.  
  826.     if (do_undump)
  827.     my_unexec();
  828.  
  829.   just_doit:        /* come here if running an undumped a.out */
  830.     argc--,argv++;    /* skip name of script */
  831.     if (doswitches) {
  832.     for (; argc > 0 && **argv == '-'; argc--,argv++) {
  833.         if (argv[0][1] == '-') {
  834.         argc--,argv++;
  835.         break;
  836.         }
  837.         if (s = index(argv[0], '=')) {
  838.         *s++ = '\0';
  839.         str_set(stab_val(stabent(argv[0]+1,TRUE)),s);
  840.         }
  841.         else
  842.         str_numset(stab_val(stabent(argv[0]+1,TRUE)),(double)1.0);
  843.     }
  844.     }
  845. #ifdef TAINT
  846.     tainted = 1;
  847. #endif
  848.     if (tmpstab = stabent("0",allstabs)) {
  849.     str_set(stab_val(tmpstab),origfilename);
  850.     magicname("0", Nullch, 0);
  851.     }
  852.     if (tmpstab = stabent("\030",allstabs))
  853.     str_set(stab_val(tmpstab),origargv[0]);
  854.     if (argvstab = stabent("ARGV",allstabs)) {
  855.     argvstab->str_pok |= SP_MULTI;
  856.     (void)aadd(argvstab);
  857.     aclear(stab_array(argvstab));
  858.     for (; argc > 0; argc--,argv++) {
  859.         (void)apush(stab_array(argvstab),str_make(argv[0],0));
  860.     }
  861.     }
  862. #ifdef TAINT
  863.     (void) stabent("ENV",TRUE);        /* must test PATH and IFS */
  864. #endif
  865.     if (envstab = stabent("ENV",allstabs)) {
  866.     envstab->str_pok |= SP_MULTI;
  867.     (void)hadd(envstab);
  868.     hclear(stab_hash(envstab), FALSE);
  869.     if (env != environ)
  870.         environ[0] = Nullch;
  871.     for (; *env; env++) {
  872.         if (!(s = index(*env,'=')))
  873.         continue;
  874.         *s++ = '\0';
  875.         str = str_make(s--,0);
  876.         str_magic(str, envstab, 'E', *env, s - *env);
  877.         (void)hstore(stab_hash(envstab), *env, s - *env, str, 0);
  878.         *s = '=';
  879.     }
  880.     }
  881. #ifdef TAINT
  882.     tainted = 0;
  883. #endif
  884.     if (tmpstab = stabent("$",allstabs))
  885.     str_numset(STAB_STR(tmpstab),(double)getpid());
  886.  
  887.     if (dowarn) {
  888.     stab_check('A','Z');
  889.     stab_check('a','z');
  890.     }
  891.  
  892.     if (setjmp(top_env))    /* sets goto_targ on longjump */
  893.     loop_ptr = -1;        /* start label stack again */
  894.  
  895. #ifdef DEBUGGING
  896.     if (debug & 1024)
  897.     dump_all();
  898.     if (debug)
  899.     fprintf(stderr,"\nEXECUTING...\n\n");
  900. #endif
  901.  
  902.     if (minus_c) {
  903.     fprintf(stderr,"%s syntax OK\n", origfilename);
  904.     exit(0);
  905.     }
  906.  
  907.     /* do it */
  908.  
  909.     (void) cmd_exec(main_root,G_SCALAR,-1);
  910.  
  911.     if (goto_targ)
  912.     fatal("Can't find label \"%s\"--aborting",goto_targ);
  913.     exit(0);
  914.     /* NOTREACHED */
  915. }
  916.  
  917. void
  918. magicalize(list)
  919. register char *list;
  920. {
  921.     char sym[2];
  922.  
  923.     sym[1] = '\0';
  924.     while (*sym = *list++)
  925.     magicname(sym, Nullch, 0);
  926. }
  927.  
  928. void
  929. magicname(sym,name,namlen)
  930. char *sym;
  931. char *name;
  932. int namlen;
  933. {
  934.     register STAB *stab;
  935.  
  936.     if (stab = stabent(sym,allstabs)) {
  937.     stab_flags(stab) = SF_VMAGIC;
  938.     str_magic(stab_val(stab), stab, 0, name, namlen);
  939.     }
  940. }
  941.  
  942. static void
  943. incpush(p)
  944. char *p;
  945. {
  946.     char *s;
  947.  
  948.     if (!p)
  949.     return;
  950.  
  951.     /* Break at all separators */
  952.     while (*p) {
  953.     /* First, skip any consecutive separators */
  954.     while ( *p == PERLLIB_SEP ) {
  955.         /* Uncomment the next line for PATH semantics */
  956.         /* (void)apush(stab_array(incstab), str_make(".", 1)); */
  957.         p++;
  958.     }
  959.     if ( (s = index(p, PERLLIB_SEP)) != Nullch ) {
  960.         (void)apush(stab_array(incstab), str_make(p, (int)(s - p)));
  961.         p = s + 1;
  962.     } else {
  963.         (void)apush(stab_array(incstab), str_make(p, 0));
  964.         break;
  965.     }
  966.     }
  967. }
  968.  
  969. void
  970. savelines(array, str)
  971. ARRAY *array;
  972. STR *str;
  973. {
  974.     register char *s = str->str_ptr;
  975.     register char *send = str->str_ptr + str->str_cur;
  976.     register char *t;
  977.     register int line = 1;
  978.  
  979.     while (s && s < send) {
  980.     STR *tmpstr = Str_new(85,0);
  981.  
  982.     t = index(s, '\n');
  983.     if (t)
  984.         t++;
  985.     else
  986.         t = send;
  987.  
  988.     str_nset(tmpstr, s, t - s);
  989.     astore(array, line++, tmpstr);
  990.     s = t;
  991.     }
  992. }
  993.  
  994. /* this routine is in perl.c by virtue of being sort of an alternate main() */
  995.  
  996. int
  997. do_eval(str,optype,stash,savecmd,gimme,arglast)
  998. STR *str;
  999. int optype;
  1000. HASH *stash;
  1001. int savecmd;
  1002. int gimme;
  1003. int *arglast;
  1004. {
  1005.     STR **st = stack->ary_array;
  1006.     int retval;
  1007.     CMD *myroot = Nullcmd;
  1008.     ARRAY *ar;
  1009.     int i;
  1010.     CMD * VOLATILE oldcurcmd = curcmd;
  1011.     VOLATILE int oldtmps_base = tmps_base;
  1012.     VOLATILE int oldsave = savestack->ary_fill;
  1013.     VOLATILE int oldperldb = perldb;
  1014.     SPAT * VOLATILE oldspat = curspat;
  1015.     SPAT * VOLATILE oldlspat = lastspat;
  1016.     static char *last_eval = Nullch;
  1017.     static long last_elen = 0;
  1018.     static CMD *last_root = Nullcmd;
  1019.     VOLATILE int sp = arglast[0];
  1020.     char *specfilename;
  1021.     char *tmpfilename;
  1022.     int parsing = 1;
  1023.  
  1024.     tmps_base = tmps_max;
  1025.     if (curstash != stash) {
  1026.     (void)savehptr(&curstash);
  1027.     curstash = stash;
  1028.     }
  1029.     str_set(stab_val(stabent("@",TRUE)),"");
  1030.     if (curcmd->c_line == 0)        /* don't debug debugger... */
  1031.     perldb = FALSE;
  1032.     curcmd = &compiling;
  1033.     if (optype == O_EVAL) {        /* normal eval */
  1034.     curcmd->c_filestab = fstab("(eval)");
  1035.     curcmd->c_line = 1;
  1036.     str_sset(linestr,str);
  1037.     str_cat(linestr,";\n;\n");    /* be kind to them */
  1038.     if (perldb)
  1039.         savelines(stab_xarray(curcmd->c_filestab), linestr);
  1040.     }
  1041.     else {
  1042.     if (last_root && !in_eval) {
  1043.         Safefree(last_eval);
  1044.         last_eval = Nullch;
  1045.         cmd_free(last_root);
  1046.         last_root = Nullcmd;
  1047.     }
  1048.     specfilename = str_get(str);
  1049.     str_set(linestr,"");
  1050.     if (optype == O_REQUIRE && &str_undef !=
  1051.       hfetch(stab_hash(incstab), specfilename, strlen(specfilename), 0)) {
  1052.         curcmd = oldcurcmd;
  1053.         tmps_base = oldtmps_base;
  1054.         st[++sp] = &str_yes;
  1055.         perldb = oldperldb;
  1056.         return sp;
  1057.     }
  1058.     tmpfilename = savestr(specfilename);
  1059.     if (*tmpfilename == '/' ||
  1060.         (*tmpfilename == '.' && 
  1061.         (tmpfilename[1] == '/' ||
  1062.          (tmpfilename[1] == '.' && tmpfilename[2] == '/'))))
  1063.     {
  1064.         rsfp = fopen(tmpfilename,"r");
  1065.     }
  1066.     else {
  1067.         ar = stab_array(incstab);
  1068.         for (i = 0; i <= ar->ary_fill; i++) {
  1069.         (void)sprintf(buf, "%s/%s",
  1070.           str_get(afetch(ar,i,TRUE)), specfilename);
  1071.         rsfp = fopen(buf,"r");
  1072.         if (rsfp) {
  1073.             char *s = buf;
  1074.  
  1075.             if (*s == '.' && s[1] == '/')
  1076.             s += 2;
  1077.             Safefree(tmpfilename);
  1078.             tmpfilename = savestr(s);
  1079.             break;
  1080.         }
  1081.         }
  1082.     }
  1083.     curcmd->c_filestab = fstab(tmpfilename);
  1084.     Safefree(tmpfilename);
  1085.     tmpfilename = Nullch;
  1086.     if (!rsfp) {
  1087.         curcmd = oldcurcmd;
  1088.         tmps_base = oldtmps_base;
  1089.         if (optype == O_REQUIRE) {
  1090.         sprintf(tokenbuf,"Can't locate %s in @INC", specfilename);
  1091.         if (instr(tokenbuf,".h "))
  1092.             strcat(tokenbuf," (change .h to .ph maybe?)");
  1093.         if (instr(tokenbuf,".ph "))
  1094.             strcat(tokenbuf," (did you run h2ph?)");
  1095.         fatal("%s",tokenbuf);
  1096.         }
  1097.         if (gimme != G_ARRAY)
  1098.         st[++sp] = &str_undef;
  1099.         perldb = oldperldb;
  1100.         return sp;
  1101.     }
  1102.     curcmd->c_line = 0;
  1103.     }
  1104.     in_eval++;
  1105.     oldoldbufptr = oldbufptr = bufptr = str_get(linestr);
  1106.     bufend = bufptr + linestr->str_cur;
  1107.     if (++loop_ptr >= loop_max) {
  1108.     loop_max += 128;
  1109.     Renew(loop_stack, loop_max, struct loop);
  1110.     }
  1111.     loop_stack[loop_ptr].loop_label = "_EVAL_";
  1112.     loop_stack[loop_ptr].loop_sp = sp;
  1113. #ifdef DEBUGGING
  1114.     if (debug & 4) {
  1115.     deb("(Pushing label #%d _EVAL_)\n", loop_ptr);
  1116.     }
  1117. #endif
  1118.     eval_root = Nullcmd;
  1119.     if (setjmp(loop_stack[loop_ptr].loop_env)) {
  1120.     retval = 1;
  1121.     }
  1122.     else {
  1123.     error_count = 0;
  1124.     if (rsfp) {
  1125.         retval = yyparse();
  1126.         retval |= error_count;
  1127.     }
  1128.     else if (last_root && last_elen == bufend - bufptr
  1129.       && *bufptr == *last_eval && !bcmp(bufptr,last_eval,last_elen)){
  1130.         retval = 0;
  1131.         eval_root = last_root;    /* no point in reparsing */
  1132.     }
  1133.     else if (in_eval == 1 && !savecmd) {
  1134.         if (last_root) {
  1135.         Safefree(last_eval);
  1136.         last_eval = Nullch;
  1137.         cmd_free(last_root);
  1138.         }
  1139.         last_root = Nullcmd;
  1140.         last_elen = bufend - bufptr;
  1141.         last_eval = nsavestr(bufptr, last_elen);
  1142.         retval = yyparse();
  1143.         retval |= error_count;
  1144.         if (!retval)
  1145.         last_root = eval_root;
  1146.         if (!last_root) {
  1147.         Safefree(last_eval);
  1148.         last_eval = Nullch;
  1149.         }
  1150.     }
  1151.     else
  1152.         retval = yyparse();
  1153.     }
  1154.     myroot = eval_root;        /* in case cmd_exec does another eval! */
  1155.  
  1156.     if (retval || error_count) {
  1157.     st = stack->ary_array;
  1158.     sp = arglast[0];
  1159.     if (gimme != G_ARRAY)
  1160.         st[++sp] = &str_undef;
  1161.     if (parsing) {
  1162. #ifndef MANGLEDPARSE
  1163. #ifdef DEBUGGING
  1164.         if (debug & 128)
  1165.         fprintf(stderr,"Freeing eval_root %lx\n",(long)eval_root);
  1166. #endif
  1167.         cmd_free(eval_root);
  1168. #endif
  1169.         /*SUPPRESS 29*/ /*SUPPRESS 30*/
  1170.         if ((CMD*)eval_root == last_root)
  1171.         last_root = Nullcmd;
  1172.         eval_root = myroot = Nullcmd;
  1173.     }
  1174.     if (rsfp) {
  1175.         fclose(rsfp);
  1176.         rsfp = 0;
  1177.     }
  1178.     }
  1179.     else {
  1180.     parsing = 0;
  1181.     sp = cmd_exec(eval_root,gimme,sp);
  1182.     st = stack->ary_array;
  1183.     for (i = arglast[0] + 1; i <= sp; i++)
  1184.         st[i] = str_mortal(st[i]);
  1185.                 /* if we don't save result, free zaps it */
  1186.     if (savecmd)
  1187.         eval_root = myroot;
  1188.     else if (in_eval != 1 && myroot != last_root)
  1189.         cmd_free(myroot);
  1190.         if (eval_root == myroot)
  1191.         eval_root = Nullcmd;
  1192.     }
  1193.  
  1194.     perldb = oldperldb;
  1195.     in_eval--;
  1196. #ifdef DEBUGGING
  1197.     if (debug & 4) {
  1198.     char *tmps = loop_stack[loop_ptr].loop_label;
  1199.     deb("(Popping label #%d %s)\n",loop_ptr,
  1200.         tmps ? tmps : "" );
  1201.     }
  1202. #endif
  1203.     loop_ptr--;
  1204.     tmps_base = oldtmps_base;
  1205.     curspat = oldspat;
  1206.     lastspat = oldlspat;
  1207.     if (savestack->ary_fill > oldsave)    /* let them use local() */
  1208.     restorelist(oldsave);
  1209.  
  1210.     if (optype != O_EVAL) {
  1211.     if (retval) {
  1212.         if (optype == O_REQUIRE)
  1213.         fatal("%s", str_get(stab_val(stabent("@",TRUE))));
  1214.     }
  1215.     else {
  1216.         curcmd = oldcurcmd;
  1217.         if (gimme == G_SCALAR ? str_true(st[sp]) : sp > arglast[0]) {
  1218.         (void)hstore(stab_hash(incstab), specfilename,
  1219.           strlen(specfilename), str_smake(stab_val(curcmd->c_filestab)),
  1220.               0 );
  1221.         }
  1222.         else if (optype == O_REQUIRE)
  1223.         fatal("%s did not return a true value", specfilename);
  1224.     }
  1225.     }
  1226.     curcmd = oldcurcmd;
  1227.     return sp;
  1228. }
  1229.  
  1230. int
  1231. do_try(cmd,gimme,arglast)
  1232. CMD *cmd;
  1233. int gimme;
  1234. int *arglast;
  1235. {
  1236.     STR **st = stack->ary_array;
  1237.  
  1238.     CMD * VOLATILE oldcurcmd = curcmd;
  1239.     VOLATILE int oldtmps_base = tmps_base;
  1240.     VOLATILE int oldsave = savestack->ary_fill;
  1241.     SPAT * VOLATILE oldspat = curspat;
  1242.     SPAT * VOLATILE oldlspat = lastspat;
  1243.     VOLATILE int sp = arglast[0];
  1244.  
  1245.     tmps_base = tmps_max;
  1246.     str_set(stab_val(stabent("@",TRUE)),"");
  1247.     in_eval++;
  1248.     if (++loop_ptr >= loop_max) {
  1249.     loop_max += 128;
  1250.     Renew(loop_stack, loop_max, struct loop);
  1251.     }
  1252.     loop_stack[loop_ptr].loop_label = "_EVAL_";
  1253.     loop_stack[loop_ptr].loop_sp = sp;
  1254. #ifdef DEBUGGING
  1255.     if (debug & 4) {
  1256.     deb("(Pushing label #%d _EVAL_)\n", loop_ptr);
  1257.     }
  1258. #endif
  1259.     if (setjmp(loop_stack[loop_ptr].loop_env)) {
  1260.     st = stack->ary_array;
  1261.     sp = arglast[0];
  1262.     if (gimme != G_ARRAY)
  1263.         st[++sp] = &str_undef;
  1264.     }
  1265.     else {
  1266.     sp = cmd_exec(cmd,gimme,sp);
  1267.     st = stack->ary_array;
  1268. /*    for (i = arglast[0] + 1; i <= sp; i++)
  1269.         st[i] = str_mortal(st[i]);  not needed, I think */
  1270.                 /* if we don't save result, free zaps it */
  1271.     }
  1272.  
  1273.     in_eval--;
  1274. #ifdef DEBUGGING
  1275.     if (debug & 4) {
  1276.     char *tmps = loop_stack[loop_ptr].loop_label;
  1277.     deb("(Popping label #%d %s)\n",loop_ptr,
  1278.         tmps ? tmps : "" );
  1279.     }
  1280. #endif
  1281.     loop_ptr--;
  1282.     tmps_base = oldtmps_base;
  1283.     curspat = oldspat;
  1284.     lastspat = oldlspat;
  1285.     curcmd = oldcurcmd;
  1286.     if (savestack->ary_fill > oldsave)    /* let them use local() */
  1287.     restorelist(oldsave);
  1288.  
  1289.     return sp;
  1290. }
  1291.  
  1292. /* This routine handles any switches that can be given during run */
  1293.  
  1294. static char *
  1295. moreswitches(s)
  1296. char *s;
  1297. {
  1298.     int numlen;
  1299.  
  1300.     switch (*s) {
  1301.     case '0':
  1302.     nrschar = scanoct(s, 4, &numlen);
  1303.     nrs = nsavestr("\n",1);
  1304.     *nrs = nrschar;
  1305.     if (nrschar > 0377) {
  1306.         nrslen = 0;
  1307.         nrs = "";
  1308.     }
  1309.     else if (!nrschar && numlen >= 2) {
  1310.         nrslen = 2;
  1311.         nrs = "\n\n";
  1312.         nrschar = '\n';
  1313.     }
  1314.     return s + numlen;
  1315.     case 'a':
  1316.     minus_a = TRUE;
  1317.     s++;
  1318.     return s;
  1319.     case 'c':
  1320.     minus_c = TRUE;
  1321.     s++;
  1322.     return s;
  1323.     case 'd':
  1324. #ifdef TAINT
  1325.     if (euid != uid || egid != gid)
  1326.         fatal("No -d allowed in setuid scripts");
  1327. #endif
  1328.     perldb = TRUE;
  1329.     s++;
  1330.     return s;
  1331.     case 'D':
  1332. #ifdef DEBUGGING
  1333. #ifdef TAINT
  1334.     if (euid != uid || egid != gid)
  1335.         fatal("No -D allowed in setuid scripts");
  1336. #endif
  1337.     debug = atoi(s+1) | 32768;
  1338. #else
  1339.     warn("Recompile perl with -DDEBUGGING to use -D switch\n");
  1340. #endif
  1341.     /*SUPPRESS 530*/
  1342.     for (s++; isDIGIT(*s); s++) ;
  1343.     return s;
  1344.     case 'i':
  1345.     inplace = savestr(s+1);
  1346.     /*SUPPRESS 530*/
  1347.     for (s = inplace; *s && !isSPACE(*s); s++) ;
  1348.     *s = '\0';
  1349.     break;
  1350.     case 'I':
  1351. #ifdef TAINT
  1352.     if (euid != uid || egid != gid)
  1353.         fatal("No -I allowed in setuid scripts");
  1354. #endif
  1355.     if (*++s) {
  1356.         (void)apush(stab_array(incstab),str_make(s,0));
  1357.     }
  1358.     else
  1359.         fatal("No space allowed after -I");
  1360.     break;
  1361.     case 'l':
  1362.     minus_l = TRUE;
  1363.     s++;
  1364.     if (isDIGIT(*s)) {
  1365.         ors = savestr("\n");
  1366.         orslen = 1;
  1367.         *ors = scanoct(s, 3 + (*s == '0'), &numlen);
  1368.         s += numlen;
  1369.     }
  1370.     else {
  1371.         ors = nsavestr(nrs,nrslen);
  1372.         orslen = nrslen;
  1373.     }
  1374.     return s;
  1375.     case 'n':
  1376.     minus_n = TRUE;
  1377.     s++;
  1378.     return s;
  1379.     case 'p':
  1380.     minus_p = TRUE;
  1381.     s++;
  1382.     return s;
  1383.     case 'u':
  1384.     do_undump = TRUE;
  1385.     s++;
  1386.     return s;
  1387.     case 'U':
  1388.     unsafe = TRUE;
  1389.     s++;
  1390.     return s;
  1391.     case 'v':
  1392.     fputs("\nThis is perl, version 4.0\n\n",stdout);
  1393.     fputs(rcsid,stdout);
  1394.     fputs("\nCopyright (c) 1989, 1990, 1991, Larry Wall\n",stdout);
  1395. #ifdef MSDOS
  1396.     fputs("MS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n",
  1397.     stdout);
  1398. #ifdef DJGPP
  1399.     fputs("MS-DOS (using DJGPP) Copyright (c) 1992, Hitoshi Doi\n", stdout);
  1400.     fputs("Additional changes for patch36 Copyright (c) 1993, Ian Nandhra\n",
  1401.     stdout);
  1402. #endif /* DJGPP */
  1403. #ifdef OS2
  1404.         fputs("OS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n",
  1405.         stdout);
  1406. #endif
  1407. #endif
  1408. #ifdef atarist
  1409.         fputs("atariST series port, ++jrb  bammi@cadence.com\n", stdout);
  1410. #endif
  1411.     fputs("\n\
  1412. Perl may be copied only under the terms of either the Artistic License or the\n\
  1413. GNU General Public License, which may be found in the Perl 4.0 source kit.\n",stdout);
  1414. #ifdef MSDOS
  1415. #ifndef DJGPP
  1416.         usage(origargv[0]);
  1417. #endif /* !DJGPP */
  1418. #endif
  1419.     exit(0);
  1420.     case 'w':
  1421.     dowarn = TRUE;
  1422.     s++;
  1423.     return s;
  1424.     case ' ':
  1425.     case '\n':
  1426.     case '\t':
  1427.     break;
  1428.     default:
  1429.     fatal("Switch meaningless after -x: -%s",s);
  1430.     }
  1431.     return Nullch;
  1432. }
  1433.  
  1434. /* compliments of Tom Christiansen */
  1435.  
  1436. /* unexec() can be found in the Gnu emacs distribution */
  1437.  
  1438. void
  1439. my_unexec()
  1440. {
  1441. #ifdef UNEXEC
  1442.     int    status;
  1443.     extern int etext;
  1444.     static char dumpname[BUFSIZ];
  1445.     static char perlpath[256];
  1446.  
  1447.     sprintf (dumpname, "%s.perldump", origfilename);
  1448.     sprintf (perlpath, "%s/perl", BIN);
  1449.  
  1450.     status = unexec(dumpname, perlpath, &etext, sbrk(0), 0);
  1451.     if (status)
  1452.     fprintf(stderr, "unexec of %s into %s failed!\n", perlpath, dumpname);
  1453.     exit(status);
  1454. #else
  1455. #ifdef DOSISH
  1456.     abort();    /* nothing else to do */
  1457. #else /* ! MSDOS */
  1458. #   ifndef SIGABRT
  1459. #    define SIGABRT SIGILL
  1460. #   endif
  1461. #   ifndef SIGILL
  1462. #    define SIGILL 6        /* blech */
  1463. #   endif
  1464.     kill(getpid(),SIGABRT);    /* for use with undump */
  1465. #endif /* ! MSDOS */
  1466. #endif
  1467. }
  1468.  
  1469.