home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1994 October / usenetsourcesnewsgroupsinfomagicoctober1994disk2.iso / misc / volume18 / perl / part16 < prev    next >
Internet Message Format  |  1991-04-16  |  51KB
  1. From: lwall@netlabs.com (Larry Wall)
  2. Newsgroups: comp.sources.misc
  3. Subject: v18i034:  perl - The perl programming language, Part16/36
  4. Message-ID: <1991Apr16.185430.874@sparky.IMD.Sterling.COM>
  5. Date: 16 Apr 91 18:54:30 GMT
  6. Approved: kent@sparky.imd.sterling.com
  7. X-Checksum-Snefru: 89266026 5d1bcbee 30d38392 89a80905
  8.  
  9. Submitted-by: Larry Wall <lwall@netlabs.com>
  10. Posting-number: Volume 18, Issue 34
  11. Archive-name: perl/part16
  12.  
  13. [There are 36 kits for perl version 4.0.]
  14.  
  15. #! /bin/sh
  16.  
  17. # Make a new directory for the perl sources, cd to it, and run kits 1
  18. # thru 36 through sh.  When all 36 kits have been run, read README.
  19.  
  20. echo "This is perl 4.0 kit 16 (of 36).  If kit 16 is complete, the line"
  21. echo '"'"End of kit 16 (of 36)"'" will echo at the end.'
  22. echo ""
  23. export PATH || (echo "You didn't use sh, you clunch." ; kill $$)
  24. mkdir emacs 2>/dev/null
  25. echo Extracting perl.c
  26. sed >perl.c <<'!STUFFY!FUNK!' -e 's/X//'
  27. Xchar rcsid[] = "$RCSfile: perl.c,v $$Revision: 4.0.1.1 $$Date: 91/04/11 17:49:05 $\nPatch level: ###\n";
  28. X/*
  29. X *    Copyright (c) 1989, Larry Wall
  30. X *
  31. X *    You may distribute under the terms of the GNU General Public License
  32. X *    as specified in the README file that comes with the perl 3.0 kit.
  33. X *
  34. X * $Log:    perl.c,v $
  35. X * Revision 4.0.1.1  91/04/11  17:49:05  lwall
  36. X * patch1: fixed undefined environ problem
  37. X * 
  38. X * Revision 4.0  91/03/20  01:37:44  lwall
  39. X * 4.0 baseline.
  40. X * 
  41. X */
  42. X
  43. X#include "EXTERN.h"
  44. X#include "perl.h"
  45. X#include "perly.h"
  46. X#ifdef MSDOS
  47. X#include "patchlev.h"
  48. X#else
  49. X#include "patchlevel.h"
  50. X#endif
  51. X
  52. X#ifdef IAMSUID
  53. X#ifndef DOSUID
  54. X#define DOSUID
  55. X#endif
  56. X#endif
  57. X
  58. X#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
  59. X#ifdef DOSUID
  60. X#undef DOSUID
  61. X#endif
  62. X#endif
  63. X
  64. Xstatic char* moreswitches();
  65. Xstatic char* cddir;
  66. Xstatic bool minus_c;
  67. Xstatic char patchlevel[6];
  68. Xstatic char *nrs = "\n";
  69. Xstatic int nrschar = '\n';      /* final char of rs, or 0777 if none */
  70. Xstatic int nrslen = 1;
  71. X
  72. Xmain(argc,argv,env)
  73. Xregister int argc;
  74. Xregister char **argv;
  75. Xregister char **env;
  76. X{
  77. X    register STR *str;
  78. X    register char *s;
  79. X    char *index(), *strcpy(), *getenv();
  80. X    bool dosearch = FALSE;
  81. X#ifdef DOSUID
  82. X    char *validarg = "";
  83. X#endif
  84. X
  85. X#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
  86. X#ifdef IAMSUID
  87. X#undef IAMSUID
  88. X    fatal("suidperl is no longer needed since the kernel can now execute\n\
  89. Xsetuid perl scripts securely.\n");
  90. X#endif
  91. X#endif
  92. X
  93. X    origargv = argv;
  94. X    origargc = argc;
  95. X    origenviron = environ;
  96. X    uid = (int)getuid();
  97. X    euid = (int)geteuid();
  98. X    gid = (int)getgid();
  99. X    egid = (int)getegid();
  100. X    sprintf(patchlevel,"%3.3s%2.2d", index(rcsid,'4'), PATCHLEVEL);
  101. X#ifdef MSDOS
  102. X    /*
  103. X     * There is no way we can refer to them from Perl so close them to save
  104. X     * space.  The other alternative would be to provide STDAUX and STDPRN
  105. X     * filehandles.
  106. X     */
  107. X    (void)fclose(stdaux);
  108. X    (void)fclose(stdprn);
  109. X#endif
  110. X    if (do_undump) {
  111. X    origfilename = savestr(argv[0]);
  112. X    do_undump = 0;
  113. X    loop_ptr = -1;        /* start label stack again */
  114. X    goto just_doit;
  115. X    }
  116. X    (void)sprintf(index(rcsid,'#'), "%d\n", PATCHLEVEL);
  117. X    linestr = Str_new(65,80);
  118. X    str_nset(linestr,"",0);
  119. X    str = str_make("",0);        /* first used for -I flags */
  120. X    curstash = defstash = hnew(0);
  121. X    curstname = str_make("main",4);
  122. X    stab_xhash(stabent("_main",TRUE)) = defstash;
  123. X    defstash->tbl_name = "main";
  124. X    incstab = hadd(aadd(stabent("INC",TRUE)));
  125. X    incstab->str_pok |= SP_MULTI;
  126. X    for (argc--,argv++; argc > 0; argc--,argv++) {
  127. X    if (argv[0][0] != '-' || !argv[0][1])
  128. X        break;
  129. X#ifdef DOSUID
  130. X    if (*validarg)
  131. X    validarg = " PHOOEY ";
  132. X    else
  133. X    validarg = argv[0];
  134. X#endif
  135. X    s = argv[0]+1;
  136. X      reswitch:
  137. X    switch (*s) {
  138. X    case '0':
  139. X    case 'a':
  140. X    case 'c':
  141. X    case 'd':
  142. X    case 'D':
  143. X    case 'i':
  144. X    case 'l':
  145. X    case 'n':
  146. X    case 'p':
  147. X    case 'u':
  148. X    case 'U':
  149. X    case 'v':
  150. X    case 'w':
  151. X        if (s = moreswitches(s))
  152. X        goto reswitch;
  153. X        break;
  154. X
  155. X    case 'e':
  156. X#ifdef TAINT
  157. X        if (euid != uid || egid != gid)
  158. X        fatal("No -e allowed in setuid scripts");
  159. X#endif
  160. X        if (!e_fp) {
  161. X            e_tmpname = savestr(TMPPATH);
  162. X        (void)mktemp(e_tmpname);
  163. X        e_fp = fopen(e_tmpname,"w");
  164. X        if (!e_fp)
  165. X            fatal("Cannot open temporary file");
  166. X        }
  167. X        if (argv[1]) {
  168. X        fputs(argv[1],e_fp);
  169. X        argc--,argv++;
  170. X        }
  171. X        (void)putc('\n', e_fp);
  172. X        break;
  173. X    case 'I':
  174. X#ifdef TAINT
  175. X        if (euid != uid || egid != gid)
  176. X        fatal("No -I allowed in setuid scripts");
  177. X#endif
  178. X        str_cat(str,"-");
  179. X        str_cat(str,s);
  180. X        str_cat(str," ");
  181. X        if (*++s) {
  182. X        (void)apush(stab_array(incstab),str_make(s,0));
  183. X        }
  184. X        else if (argv[1]) {
  185. X        (void)apush(stab_array(incstab),str_make(argv[1],0));
  186. X        str_cat(str,argv[1]);
  187. X        argc--,argv++;
  188. X        str_cat(str," ");
  189. X        }
  190. X        break;
  191. X    case 'P':
  192. X#ifdef TAINT
  193. X        if (euid != uid || egid != gid)
  194. X        fatal("No -P allowed in setuid scripts");
  195. X#endif
  196. X        preprocess = TRUE;
  197. X        s++;
  198. X        goto reswitch;
  199. X    case 's':
  200. X#ifdef TAINT
  201. X        if (euid != uid || egid != gid)
  202. X        fatal("No -s allowed in setuid scripts");
  203. X#endif
  204. X        doswitches = TRUE;
  205. X        s++;
  206. X        goto reswitch;
  207. X    case 'S':
  208. X        dosearch = TRUE;
  209. X        s++;
  210. X        goto reswitch;
  211. X    case 'x':
  212. X        doextract = TRUE;
  213. X        s++;
  214. X        if (*s)
  215. X        cddir = savestr(s);
  216. X        break;
  217. X    case '-':
  218. X        argc--,argv++;
  219. X        goto switch_end;
  220. X    case 0:
  221. X        break;
  222. X    default:
  223. X        fatal("Unrecognized switch: -%s",s);
  224. X    }
  225. X    }
  226. X  switch_end:
  227. X    if (e_fp) {
  228. X    (void)fclose(e_fp);
  229. X    argc++,argv--;
  230. X    argv[0] = e_tmpname;
  231. X    }
  232. X
  233. X#ifdef MSDOS
  234. X#define PERLLIB_SEP ';'
  235. X#else
  236. X#define PERLLIB_SEP ':'
  237. X#endif
  238. X#ifndef TAINT        /* Can't allow arbitrary PERLLIB in setuid script */
  239. X    {
  240. X    char * s2 = getenv("PERLLIB");
  241. X
  242. X    if ( s2 ) {
  243. X        /* Break at all separators */
  244. X        while ( *s2 ) {
  245. X        /* First, skip any consecutive separators */
  246. X        while ( *s2 == PERLLIB_SEP ) {
  247. X            /* Uncomment the next line for PATH semantics */
  248. X            /* (void)apush(stab_array(incstab),str_make(".",1)); */
  249. X            s2++;
  250. X        }
  251. X        if ( (s = index(s2,PERLLIB_SEP)) != Nullch ) {
  252. X            (void)apush(stab_array(incstab),str_make(s2,(int)(s-s2)));
  253. X            s2 = s+1;
  254. X        } else {
  255. X            (void)apush(stab_array(incstab),str_make(s2,0));
  256. X            break;
  257. X        }
  258. X        }
  259. X    }
  260. X    }
  261. X#endif /* TAINT */
  262. X
  263. X#ifndef PRIVLIB
  264. X#define PRIVLIB "/usr/local/lib/perl"
  265. X#endif
  266. X    (void)apush(stab_array(incstab),str_make(PRIVLIB,0));
  267. X    (void)apush(stab_array(incstab),str_make(".",1));
  268. X
  269. X    str_set(&str_no,No);
  270. X    str_set(&str_yes,Yes);
  271. X
  272. X    /* open script */
  273. X
  274. X    if (argv[0] == Nullch)
  275. X#ifdef MSDOS
  276. X    {
  277. X    if ( isatty(fileno(stdin)) )
  278. X      moreswitches("v");
  279. X    argv[0] = "-";
  280. X    }
  281. X#else
  282. X    argv[0] = "-";
  283. X#endif
  284. X    if (dosearch && !index(argv[0], '/') && (s = getenv("PATH"))) {
  285. X    char *xfound = Nullch, *xfailed = Nullch;
  286. X    int len;
  287. X
  288. X    bufend = s + strlen(s);
  289. X    while (*s) {
  290. X#ifndef MSDOS
  291. X        s = cpytill(tokenbuf,s,bufend,':',&len);
  292. X#else
  293. X        for (len = 0; *s && *s != ';'; tokenbuf[len++] = *s++);
  294. X        tokenbuf[len] = '\0';
  295. X#endif
  296. X        if (*s)
  297. X        s++;
  298. X#ifndef MSDOS
  299. X        if (len && tokenbuf[len-1] != '/')
  300. X#else
  301. X        if (len && tokenbuf[len-1] != '\\')
  302. X#endif
  303. X        (void)strcat(tokenbuf+len,"/");
  304. X        (void)strcat(tokenbuf+len,argv[0]);
  305. X#ifdef DEBUGGING
  306. X        if (debug & 1)
  307. X        fprintf(stderr,"Looking for %s\n",tokenbuf);
  308. X#endif
  309. X        if (stat(tokenbuf,&statbuf) < 0)        /* not there? */
  310. X        continue;
  311. X        if (S_ISREG(statbuf.st_mode)
  312. X         && cando(S_IRUSR,TRUE,&statbuf) && cando(S_IXUSR,TRUE,&statbuf)) {
  313. X        xfound = tokenbuf;              /* bingo! */
  314. X        break;
  315. X        }
  316. X        if (!xfailed)
  317. X        xfailed = savestr(tokenbuf);
  318. X    }
  319. X    if (!xfound)
  320. X        fatal("Can't execute %s", xfailed ? xfailed : argv[0] );
  321. X    if (xfailed)
  322. X        Safefree(xfailed);
  323. X    argv[0] = savestr(xfound);
  324. X    }
  325. X
  326. X    fdpid = anew(Nullstab);    /* for remembering popen pids by fd */
  327. X    pidstatus = hnew(COEFFSIZE);/* for remembering status of dead pids */
  328. X
  329. X    origfilename = savestr(argv[0]);
  330. X    curcmd->c_filestab = fstab(origfilename);
  331. X    if (strEQ(origfilename,"-"))
  332. X    argv[0] = "";
  333. X    if (preprocess) {
  334. X    str_cat(str,"-I");
  335. X    str_cat(str,PRIVLIB);
  336. X    (void)sprintf(buf, "\
  337. X%ssed %s -e '/^[^#]/b' \
  338. X -e '/^#[     ]*include[     ]/b' \
  339. X -e '/^#[     ]*define[     ]/b' \
  340. X -e '/^#[     ]*if[     ]/b' \
  341. X -e '/^#[     ]*ifdef[     ]/b' \
  342. X -e '/^#[     ]*ifndef[     ]/b' \
  343. X -e '/^#[     ]*else/b' \
  344. X -e '/^#[     ]*endif/b' \
  345. X -e 's/^#.*//' \
  346. X %s | %s -C %s %s",
  347. X#ifdef MSDOS
  348. X      "",
  349. X#else
  350. X      "/bin/",
  351. X#endif
  352. X      (doextract ? "-e '1,/^#/d\n'" : ""),
  353. X      argv[0], CPPSTDIN, str_get(str), CPPMINUS);
  354. X#ifdef DEBUGGING
  355. X    if (debug & 64) {
  356. X        fputs(buf,stderr);
  357. X        fputs("\n",stderr);
  358. X    }
  359. X#endif
  360. X    doextract = FALSE;
  361. X#ifdef IAMSUID                /* actually, this is caught earlier */
  362. X    if (euid != uid && !euid)    /* if running suidperl */
  363. X#ifdef HAS_SETEUID
  364. X        (void)seteuid(uid);        /* musn't stay setuid root */
  365. X#else
  366. X#ifdef HAS_SETREUID
  367. X        (void)setreuid(-1, uid);
  368. X#else
  369. X        setuid(uid);
  370. X#endif
  371. X#endif
  372. X#endif /* IAMSUID */
  373. X    rsfp = mypopen(buf,"r");
  374. X    }
  375. X    else if (!*argv[0])
  376. X    rsfp = stdin;
  377. X    else
  378. X    rsfp = fopen(argv[0],"r");
  379. X    if (rsfp == Nullfp) {
  380. X#ifdef DOSUID
  381. X#ifndef IAMSUID        /* in case script is not readable before setuid */
  382. X    if (euid && stat(stab_val(curcmd->c_filestab)->str_ptr,&statbuf) >= 0 &&
  383. X      statbuf.st_mode & (S_ISUID|S_ISGID)) {
  384. X        (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
  385. X        execv(buf, origargv);    /* try again */
  386. X        fatal("Can't do setuid\n");
  387. X    }
  388. X#endif
  389. X#endif
  390. X    fatal("Can't open perl script \"%s\": %s\n",
  391. X      stab_val(curcmd->c_filestab)->str_ptr, strerror(errno));
  392. X    }
  393. X    str_free(str);        /* free -I directories */
  394. X    str = Nullstr;
  395. X
  396. X    /* do we need to emulate setuid on scripts? */
  397. X
  398. X    /* This code is for those BSD systems that have setuid #! scripts disabled
  399. X     * in the kernel because of a security problem.  Merely defining DOSUID
  400. X     * in perl will not fix that problem, but if you have disabled setuid
  401. X     * scripts in the kernel, this will attempt to emulate setuid and setgid
  402. X     * on scripts that have those now-otherwise-useless bits set.  The setuid
  403. X     * root version must be called suidperl or sperlN.NNN.  If regular perl
  404. X     * discovers that it has opened a setuid script, it calls suidperl with
  405. X     * the same argv that it had.  If suidperl finds that the script it has
  406. X     * just opened is NOT setuid root, it sets the effective uid back to the
  407. X     * uid.  We don't just make perl setuid root because that loses the
  408. X     * effective uid we had before invoking perl, if it was different from the
  409. X     * uid.
  410. X     *
  411. X     * DOSUID must be defined in both perl and suidperl, and IAMSUID must
  412. X     * be defined in suidperl only.  suidperl must be setuid root.  The
  413. X     * Configure script will set this up for you if you want it.
  414. X     *
  415. X     * There is also the possibility of have a script which is running
  416. X     * set-id due to a C wrapper.  We want to do the TAINT checks
  417. X     * on these set-id scripts, but don't want to have the overhead of
  418. X     * them in normal perl, and can't use suidperl because it will lose
  419. X     * the effective uid info, so we have an additional non-setuid root
  420. X     * version called taintperl or tperlN.NNN that just does the TAINT checks.
  421. X     */
  422. X
  423. X#ifdef DOSUID
  424. X    if (fstat(fileno(rsfp),&statbuf) < 0)    /* normal stat is insecure */
  425. X    fatal("Can't stat script \"%s\"",origfilename);
  426. X    if (statbuf.st_mode & (S_ISUID|S_ISGID)) {
  427. X    int len;
  428. X
  429. X#ifdef IAMSUID
  430. X#ifndef HAS_SETREUID
  431. X    /* On this access check to make sure the directories are readable,
  432. X     * there is actually a small window that the user could use to make
  433. X     * filename point to an accessible directory.  So there is a faint
  434. X     * chance that someone could execute a setuid script down in a
  435. X     * non-accessible directory.  I don't know what to do about that.
  436. X     * But I don't think it's too important.  The manual lies when
  437. X     * it says access() is useful in setuid programs.
  438. X     */
  439. X    if (access(stab_val(curcmd->c_filestab)->str_ptr,1))    /*double check*/
  440. X        fatal("Permission denied");
  441. X#else
  442. X    /* If we can swap euid and uid, then we can determine access rights
  443. X     * with a simple stat of the file, and then compare device and
  444. X     * inode to make sure we did stat() on the same file we opened.
  445. X     * Then we just have to make sure he or she can execute it.
  446. X     */
  447. X    {
  448. X        struct stat tmpstatbuf;
  449. X
  450. X        if (setreuid(euid,uid) < 0 || getuid() != euid || geteuid() != uid)
  451. X        fatal("Can't swap uid and euid");    /* really paranoid */
  452. X        if (stat(stab_val(curcmd->c_filestab)->str_ptr,&tmpstatbuf) < 0)
  453. X        fatal("Permission denied");    /* testing full pathname here */
  454. X        if (tmpstatbuf.st_dev != statbuf.st_dev ||
  455. X        tmpstatbuf.st_ino != statbuf.st_ino) {
  456. X        (void)fclose(rsfp);
  457. X        if (rsfp = mypopen("/bin/mail root","w")) {    /* heh, heh */
  458. X            fprintf(rsfp,
  459. X"User %d tried to run dev %d ino %d in place of dev %d ino %d!\n\
  460. X(Filename of set-id script was %s, uid %d gid %d.)\n\nSincerely,\nperl\n",
  461. X            uid,tmpstatbuf.st_dev, tmpstatbuf.st_ino,
  462. X            statbuf.st_dev, statbuf.st_ino,
  463. X            stab_val(curcmd->c_filestab)->str_ptr,
  464. X            statbuf.st_uid, statbuf.st_gid);
  465. X            (void)mypclose(rsfp);
  466. X        }
  467. X        fatal("Permission denied\n");
  468. X        }
  469. X        if (setreuid(uid,euid) < 0 || getuid() != uid || geteuid() != euid)
  470. X        fatal("Can't reswap uid and euid");
  471. X        if (!cando(S_IXUSR,FALSE,&statbuf))        /* can real uid exec? */
  472. X        fatal("Permission denied\n");
  473. X    }
  474. X#endif /* HAS_SETREUID */
  475. X#endif /* IAMSUID */
  476. X
  477. X    if (!S_ISREG(statbuf.st_mode))
  478. X        fatal("Permission denied");
  479. X    if (statbuf.st_mode & S_IWOTH)
  480. X        fatal("Setuid/gid script is writable by world");
  481. X    doswitches = FALSE;        /* -s is insecure in suid */
  482. X    curcmd->c_line++;
  483. X    if (fgets(tokenbuf,sizeof tokenbuf, rsfp) == Nullch ||
  484. X      strnNE(tokenbuf,"#!",2) )    /* required even on Sys V */
  485. X        fatal("No #! line");
  486. X    s = tokenbuf+2;
  487. X    if (*s == ' ') s++;
  488. X    while (!isspace(*s)) s++;
  489. X    if (strnNE(s-4,"perl",4) && strnNE(s-9,"perl",4))  /* sanity check */
  490. X        fatal("Not a perl script");
  491. X    while (*s == ' ' || *s == '\t') s++;
  492. X    /*
  493. X     * #! arg must be what we saw above.  They can invoke it by
  494. X     * mentioning suidperl explicitly, but they may not add any strange
  495. X     * arguments beyond what #! says if they do invoke suidperl that way.
  496. X     */
  497. X    len = strlen(validarg);
  498. X    if (strEQ(validarg," PHOOEY ") ||
  499. X        strnNE(s,validarg,len) || !isspace(s[len]))
  500. X        fatal("Args must match #! line");
  501. X
  502. X#ifndef IAMSUID
  503. X    if (euid != uid && (statbuf.st_mode & S_ISUID) &&
  504. X        euid == statbuf.st_uid)
  505. X        if (!do_undump)
  506. X        fatal("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
  507. XFIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
  508. X#endif /* IAMSUID */
  509. X
  510. X    if (euid) {    /* oops, we're not the setuid root perl */
  511. X        (void)fclose(rsfp);
  512. X#ifndef IAMSUID
  513. X        (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
  514. X        execv(buf, origargv);    /* try again */
  515. X#endif
  516. X        fatal("Can't do setuid\n");
  517. X    }
  518. X
  519. X    if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid)
  520. X#ifdef HAS_SETEGID
  521. X        (void)setegid(statbuf.st_gid);
  522. X#else
  523. X#ifdef HAS_SETREGID
  524. X        (void)setregid((GIDTYPE)-1,statbuf.st_gid);
  525. X#else
  526. X        setgid(statbuf.st_gid);
  527. X#endif
  528. X#endif
  529. X    if (statbuf.st_mode & S_ISUID) {
  530. X        if (statbuf.st_uid != euid)
  531. X#ifdef HAS_SETEUID
  532. X        (void)seteuid(statbuf.st_uid);    /* all that for this */
  533. X#else
  534. X#ifdef HAS_SETREUID
  535. X        (void)setreuid((UIDTYPE)-1,statbuf.st_uid);
  536. X#else
  537. X        setuid(statbuf.st_uid);
  538. X#endif
  539. X#endif
  540. X    }
  541. X    else if (uid)            /* oops, mustn't run as root */
  542. X#ifdef HAS_SETEUID
  543. X        (void)seteuid((UIDTYPE)uid);
  544. X#else
  545. X#ifdef HAS_SETREUID
  546. X        (void)setreuid((UIDTYPE)-1,(UIDTYPE)uid);
  547. X#else
  548. X        setuid((UIDTYPE)uid);
  549. X#endif
  550. X#endif
  551. X    uid = (int)getuid();
  552. X    euid = (int)geteuid();
  553. X    gid = (int)getgid();
  554. X    egid = (int)getegid();
  555. X    if (!cando(S_IXUSR,TRUE,&statbuf))
  556. X        fatal("Permission denied\n");    /* they can't do this */
  557. X    }
  558. X#ifdef IAMSUID
  559. X    else if (preprocess)
  560. X    fatal("-P not allowed for setuid/setgid script\n");
  561. X    else
  562. X    fatal("Script is not setuid/setgid in suidperl\n");
  563. X#else
  564. X#ifndef TAINT        /* we aren't taintperl or suidperl */
  565. X    /* script has a wrapper--can't run suidperl or we lose euid */
  566. X    else if (euid != uid || egid != gid) {
  567. X    (void)fclose(rsfp);
  568. X    (void)sprintf(buf, "%s/tperl%s", BIN, patchlevel);
  569. X    execv(buf, origargv);    /* try again */
  570. X    fatal("Can't run setuid script with taint checks");
  571. X    }
  572. X#endif /* TAINT */
  573. X#endif /* IAMSUID */
  574. X#else /* !DOSUID */
  575. X#ifndef TAINT        /* we aren't taintperl or suidperl */
  576. X    if (euid != uid || egid != gid) {    /* (suidperl doesn't exist, in fact) */
  577. X#ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
  578. X    fstat(fileno(rsfp),&statbuf);    /* may be either wrapped or real suid */
  579. X    if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
  580. X        ||
  581. X        (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
  582. X       )
  583. X        if (!do_undump)
  584. X        fatal("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
  585. XFIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
  586. X#endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
  587. X    /* not set-id, must be wrapped */
  588. X    (void)fclose(rsfp);
  589. X    (void)sprintf(buf, "%s/tperl%s", BIN, patchlevel);
  590. X    execv(buf, origargv);    /* try again */
  591. X    fatal("Can't run setuid script with taint checks");
  592. X    }
  593. X#endif /* TAINT */
  594. X#endif /* DOSUID */
  595. X
  596. X#if !defined(IAMSUID) && !defined(TAINT)
  597. X
  598. X    /* skip forward in input to the real script? */
  599. X
  600. X    while (doextract) {
  601. X    if ((s = str_gets(linestr, rsfp, 0)) == Nullch)
  602. X        fatal("No Perl script found in input\n");
  603. X    if (*s == '#' && s[1] == '!' && instr(s,"perl")) {
  604. X        ungetc('\n',rsfp);        /* to keep line count right */
  605. X        doextract = FALSE;
  606. X        if (s = instr(s,"perl -")) {
  607. X        s += 6;
  608. X        while (s = moreswitches(s)) ;
  609. X        }
  610. X        if (cddir && chdir(cddir) < 0)
  611. X        fatal("Can't chdir to %s",cddir);
  612. X    }
  613. X    }
  614. X#endif /* !defined(IAMSUID) && !defined(TAINT) */
  615. X
  616. X    defstab = stabent("_",TRUE);
  617. X
  618. X    if (perldb) {
  619. X    debstash = hnew(0);
  620. X    stab_xhash(stabent("_DB",TRUE)) = debstash;
  621. X    curstash = debstash;
  622. X    dbargs = stab_xarray(aadd((tmpstab = stabent("args",TRUE))));
  623. X    tmpstab->str_pok |= SP_MULTI;
  624. X    dbargs->ary_flags = 0;
  625. X    subname = str_make("main",4);
  626. X    DBstab = stabent("DB",TRUE);
  627. X    DBstab->str_pok |= SP_MULTI;
  628. X    DBline = stabent("dbline",TRUE);
  629. X    DBline->str_pok |= SP_MULTI;
  630. X    DBsub = hadd(tmpstab = stabent("sub",TRUE));
  631. X    tmpstab->str_pok |= SP_MULTI;
  632. X    DBsingle = stab_val((tmpstab = stabent("single",TRUE)));
  633. X    tmpstab->str_pok |= SP_MULTI;
  634. X    DBtrace = stab_val((tmpstab = stabent("trace",TRUE)));
  635. X    tmpstab->str_pok |= SP_MULTI;
  636. X    DBsignal = stab_val((tmpstab = stabent("signal",TRUE)));
  637. X    tmpstab->str_pok |= SP_MULTI;
  638. X    curstash = defstash;
  639. X    }
  640. X
  641. X    /* init tokener */
  642. X
  643. X    bufend = bufptr = str_get(linestr);
  644. X
  645. X    savestack = anew(Nullstab);        /* for saving non-local values */
  646. X    stack = anew(Nullstab);        /* for saving non-local values */
  647. X    stack->ary_flags = 0;        /* not a real array */
  648. X    afill(stack,63); afill(stack,-1);    /* preextend stack */
  649. X    afill(savestack,63); afill(savestack,-1);
  650. X
  651. X    /* now parse the script */
  652. X
  653. X    error_count = 0;
  654. X    if (yyparse() || error_count) {
  655. X    if (minus_c)
  656. X        fatal("%s had compilation errors.\n", origfilename);
  657. X    else {
  658. X        fatal("Execution of %s aborted due to compilation errors.\n",
  659. X        origfilename);
  660. X    }
  661. X    }
  662. X
  663. X    New(50,loop_stack,128,struct loop);
  664. X#ifdef DEBUGGING
  665. X    if (debug) {
  666. X    New(51,debname,128,char);
  667. X    New(52,debdelim,128,char);
  668. X    }
  669. X#endif
  670. X    curstash = defstash;
  671. X
  672. X    preprocess = FALSE;
  673. X    if (e_fp) {
  674. X    e_fp = Nullfp;
  675. X    (void)UNLINK(e_tmpname);
  676. X    }
  677. X
  678. X    /* initialize everything that won't change if we undump */
  679. X
  680. X    if (sigstab = stabent("SIG",allstabs)) {
  681. X    sigstab->str_pok |= SP_MULTI;
  682. X    (void)hadd(sigstab);
  683. X    }
  684. X
  685. X    magicalize("!#?^~=-%.+&*()<>,\\/[|`':\004\t\024\027");
  686. X    userinit();        /* in case linked C routines want magical variables */
  687. X
  688. X    amperstab = stabent("&",allstabs);
  689. X    leftstab = stabent("`",allstabs);
  690. X    rightstab = stabent("'",allstabs);
  691. X    sawampersand = (amperstab || leftstab || rightstab);
  692. X    if (tmpstab = stabent(":",allstabs))
  693. X    str_set(STAB_STR(tmpstab),chopset);
  694. X    if (tmpstab = stabent("\024",allstabs))
  695. X    time(&basetime);
  696. X
  697. X    /* these aren't necessarily magical */
  698. X    if (tmpstab = stabent(";",allstabs))
  699. X    str_set(STAB_STR(tmpstab),"\034");
  700. X    if (tmpstab = stabent("]",allstabs)) {
  701. X    str = STAB_STR(tmpstab);
  702. X    str_set(str,rcsid);
  703. X    str->str_u.str_nval = atof(patchlevel);
  704. X    str->str_nok = 1;
  705. X    }
  706. X    str_nset(stab_val(stabent("\"", TRUE)), " ", 1);
  707. X
  708. X    stdinstab = stabent("STDIN",TRUE);
  709. X    stdinstab->str_pok |= SP_MULTI;
  710. X    stab_io(stdinstab) = stio_new();
  711. X    stab_io(stdinstab)->ifp = stdin;
  712. X    tmpstab = stabent("stdin",TRUE);
  713. X    stab_io(tmpstab) = stab_io(stdinstab);
  714. X    tmpstab->str_pok |= SP_MULTI;
  715. X
  716. X    tmpstab = stabent("STDOUT",TRUE);
  717. X    tmpstab->str_pok |= SP_MULTI;
  718. X    stab_io(tmpstab) = stio_new();
  719. X    stab_io(tmpstab)->ofp = stab_io(tmpstab)->ifp = stdout;
  720. X    defoutstab = tmpstab;
  721. X    tmpstab = stabent("stdout",TRUE);
  722. X    stab_io(tmpstab) = stab_io(defoutstab);
  723. X    tmpstab->str_pok |= SP_MULTI;
  724. X
  725. X    curoutstab = stabent("STDERR",TRUE);
  726. X    curoutstab->str_pok |= SP_MULTI;
  727. X    stab_io(curoutstab) = stio_new();
  728. X    stab_io(curoutstab)->ofp = stab_io(curoutstab)->ifp = stderr;
  729. X    tmpstab = stabent("stderr",TRUE);
  730. X    stab_io(tmpstab) = stab_io(curoutstab);
  731. X    tmpstab->str_pok |= SP_MULTI;
  732. X    curoutstab = defoutstab;        /* switch back to STDOUT */
  733. X
  734. X    statname = Str_new(66,0);        /* last filename we did stat on */
  735. X
  736. X    /* now that script is parsed, we can modify record separator */
  737. X
  738. X    rs = nrs;
  739. X    rslen = nrslen;
  740. X    rschar = nrschar;
  741. X    str_nset(stab_val(stabent("/", TRUE)), rs, rslen);
  742. X
  743. X    if (do_undump)
  744. X    my_unexec();
  745. X
  746. X  just_doit:        /* come here if running an undumped a.out */
  747. X    argc--,argv++;    /* skip name of script */
  748. X    if (doswitches) {
  749. X    for (; argc > 0 && **argv == '-'; argc--,argv++) {
  750. X        if (argv[0][1] == '-') {
  751. X        argc--,argv++;
  752. X        break;
  753. X        }
  754. X        if (s = index(argv[0], '=')) {
  755. X        *s++ = '\0';
  756. X        str_set(stab_val(stabent(argv[0]+1,TRUE)),s);
  757. X        }
  758. X        else
  759. X        str_numset(stab_val(stabent(argv[0]+1,TRUE)),(double)1.0);
  760. X    }
  761. X    }
  762. X#ifdef TAINT
  763. X    tainted = 1;
  764. X#endif
  765. X    if (tmpstab = stabent("0",allstabs)) {
  766. X    str_set(stab_val(tmpstab),origfilename);
  767. X    magicname("0", Nullch, 0);
  768. X    }
  769. X    if (tmpstab = stabent("\020",allstabs))
  770. X    str_set(stab_val(tmpstab),origargv[0]);
  771. X    if (argvstab = stabent("ARGV",allstabs)) {
  772. X    argvstab->str_pok |= SP_MULTI;
  773. X    (void)aadd(argvstab);
  774. X    aclear(stab_array(argvstab));
  775. X    for (; argc > 0; argc--,argv++) {
  776. X        (void)apush(stab_array(argvstab),str_make(argv[0],0));
  777. X    }
  778. X    }
  779. X#ifdef TAINT
  780. X    (void) stabent("ENV",TRUE);        /* must test PATH and IFS */
  781. X#endif
  782. X    if (envstab = stabent("ENV",allstabs)) {
  783. X    envstab->str_pok |= SP_MULTI;
  784. X    (void)hadd(envstab);
  785. X    hclear(stab_hash(envstab), FALSE);
  786. X    if (env != environ)
  787. X        environ[0] = Nullch;
  788. X    for (; *env; env++) {
  789. X        if (!(s = index(*env,'=')))
  790. X        continue;
  791. X        *s++ = '\0';
  792. X        str = str_make(s--,0);
  793. X        str_magic(str, envstab, 'E', *env, s - *env);
  794. X        (void)hstore(stab_hash(envstab), *env, s - *env, str, 0);
  795. X        *s = '=';
  796. X    }
  797. X    }
  798. X#ifdef TAINT
  799. X    tainted = 0;
  800. X#endif
  801. X    if (tmpstab = stabent("$",allstabs))
  802. X    str_numset(STAB_STR(tmpstab),(double)getpid());
  803. X
  804. X    if (dowarn) {
  805. X    stab_check('A','Z');
  806. X    stab_check('a','z');
  807. X    }
  808. X
  809. X    if (setjmp(top_env))    /* sets goto_targ on longjump */
  810. X    loop_ptr = -1;        /* start label stack again */
  811. X
  812. X#ifdef DEBUGGING
  813. X    if (debug & 1024)
  814. X    dump_all();
  815. X    if (debug)
  816. X    fprintf(stderr,"\nEXECUTING...\n\n");
  817. X#endif
  818. X
  819. X    if (minus_c) {
  820. X    fprintf(stderr,"%s syntax OK\n", origfilename);
  821. X    exit(0);
  822. X    }
  823. X
  824. X    /* do it */
  825. X
  826. X    (void) cmd_exec(main_root,G_SCALAR,-1);
  827. X
  828. X    if (goto_targ)
  829. X    fatal("Can't find label \"%s\"--aborting",goto_targ);
  830. X    exit(0);
  831. X    /* NOTREACHED */
  832. X}
  833. X
  834. Xvoid
  835. Xmagicalize(list)
  836. Xregister char *list;
  837. X{
  838. X    char sym[2];
  839. X
  840. X    sym[1] = '\0';
  841. X    while (*sym = *list++)
  842. X    magicname(sym, Nullch, 0);
  843. X}
  844. X
  845. Xvoid
  846. Xmagicname(sym,name,namlen)
  847. Xchar *sym;
  848. Xchar *name;
  849. Xint namlen;
  850. X{
  851. X    register STAB *stab;
  852. X
  853. X    if (stab = stabent(sym,allstabs)) {
  854. X    stab_flags(stab) = SF_VMAGIC;
  855. X    str_magic(stab_val(stab), stab, 0, name, namlen);
  856. X    }
  857. X}
  858. X
  859. X/* this routine is in perl.c by virtue of being sort of an alternate main() */
  860. X
  861. Xint
  862. Xdo_eval(str,optype,stash,gimme,arglast)
  863. XSTR *str;
  864. Xint optype;
  865. XHASH *stash;
  866. Xint gimme;
  867. Xint *arglast;
  868. X{
  869. X    STR **st = stack->ary_array;
  870. X    int retval;
  871. X    CMD *myroot = Nullcmd;
  872. X    ARRAY *ar;
  873. X    int i;
  874. X    CMD * VOLATILE oldcurcmd = curcmd;
  875. X    VOLATILE int oldtmps_base = tmps_base;
  876. X    VOLATILE int oldsave = savestack->ary_fill;
  877. X    VOLATILE int oldperldb = perldb;
  878. X    SPAT * VOLATILE oldspat = curspat;
  879. X    SPAT * VOLATILE oldlspat = lastspat;
  880. X    static char *last_eval = Nullch;
  881. X    static CMD *last_root = Nullcmd;
  882. X    VOLATILE int sp = arglast[0];
  883. X    char *specfilename;
  884. X    char *tmpfilename;
  885. X    int parsing = 1;
  886. X
  887. X    tmps_base = tmps_max;
  888. X    if (curstash != stash) {
  889. X    (void)savehptr(&curstash);
  890. X    curstash = stash;
  891. X    }
  892. X    str_set(stab_val(stabent("@",TRUE)),"");
  893. X    if (curcmd->c_line == 0)        /* don't debug debugger... */
  894. X    perldb = FALSE;
  895. X    curcmd = &compiling;
  896. X    if (optype == O_EVAL) {        /* normal eval */
  897. X    curcmd->c_filestab = fstab("(eval)");
  898. X    curcmd->c_line = 1;
  899. X    str_sset(linestr,str);
  900. X    str_cat(linestr,";");        /* be kind to them */
  901. X    }
  902. X    else {
  903. X    if (last_root && !in_eval) {
  904. X        Safefree(last_eval);
  905. X        last_eval = Nullch;
  906. X        cmd_free(last_root);
  907. X        last_root = Nullcmd;
  908. X    }
  909. X    specfilename = str_get(str);
  910. X    str_set(linestr,"");
  911. X    if (optype == O_REQUIRE && &str_undef !=
  912. X      hfetch(stab_hash(incstab), specfilename, strlen(specfilename), 0)) {
  913. X        curcmd = oldcurcmd;
  914. X        tmps_base = oldtmps_base;
  915. X        st[++sp] = &str_yes;
  916. X        perldb = oldperldb;
  917. X        return sp;
  918. X    }
  919. X    tmpfilename = savestr(specfilename);
  920. X    if (index("/.", *tmpfilename))
  921. X        rsfp = fopen(tmpfilename,"r");
  922. X    else {
  923. X        ar = stab_array(incstab);
  924. X        for (i = 0; i <= ar->ary_fill; i++) {
  925. X        (void)sprintf(buf, "%s/%s",
  926. X          str_get(afetch(ar,i,TRUE)), specfilename);
  927. X        rsfp = fopen(buf,"r");
  928. X        if (rsfp) {
  929. X            char *s = buf;
  930. X
  931. X            if (*s == '.' && s[1] == '/')
  932. X            s += 2;
  933. X            Safefree(tmpfilename);
  934. X            tmpfilename = savestr(s);
  935. X            break;
  936. X        }
  937. X        }
  938. X    }
  939. X    curcmd->c_filestab = fstab(tmpfilename);
  940. X    Safefree(tmpfilename);
  941. X    tmpfilename = Nullch;
  942. X    if (!rsfp) {
  943. X        curcmd = oldcurcmd;
  944. X        tmps_base = oldtmps_base;
  945. X        if (optype == O_REQUIRE) {
  946. X        sprintf(tokenbuf,"Can't locate %s in @INC", specfilename);
  947. X        if (instr(tokenbuf,".h "))
  948. X            strcat(tokenbuf," (change .h to .ph maybe?)");
  949. X        if (instr(tokenbuf,".ph "))
  950. X            strcat(tokenbuf," (did you run h2ph?)");
  951. X        fatal("%s",tokenbuf);
  952. X        }
  953. X        if (gimme != G_ARRAY)
  954. X        st[++sp] = &str_undef;
  955. X        perldb = oldperldb;
  956. X        return sp;
  957. X    }
  958. X    curcmd->c_line = 0;
  959. X    }
  960. X    in_eval++;
  961. X    oldoldbufptr = oldbufptr = bufptr = str_get(linestr);
  962. X    bufend = bufptr + linestr->str_cur;
  963. X    if (++loop_ptr >= loop_max) {
  964. X    loop_max += 128;
  965. X    Renew(loop_stack, loop_max, struct loop);
  966. X    }
  967. X    loop_stack[loop_ptr].loop_label = "_EVAL_";
  968. X    loop_stack[loop_ptr].loop_sp = sp;
  969. X#ifdef DEBUGGING
  970. X    if (debug & 4) {
  971. X    deb("(Pushing label #%d _EVAL_)\n", loop_ptr);
  972. X    }
  973. X#endif
  974. X    eval_root = Nullcmd;
  975. X    if (setjmp(loop_stack[loop_ptr].loop_env)) {
  976. X    retval = 1;
  977. X    }
  978. X    else {
  979. X    error_count = 0;
  980. X    if (rsfp) {
  981. X        retval = yyparse();
  982. X        retval |= error_count;
  983. X    }
  984. X    else if (last_root && *bufptr == *last_eval && strEQ(bufptr,last_eval)){
  985. X        retval = 0;
  986. X        eval_root = last_root;    /* no point in reparsing */
  987. X    }
  988. X    else if (in_eval == 1) {
  989. X        if (last_root) {
  990. X        Safefree(last_eval);
  991. X        last_eval = Nullch;
  992. X        cmd_free(last_root);
  993. X        }
  994. X        last_root = Nullcmd;
  995. X        last_eval = savestr(bufptr);
  996. X        retval = yyparse();
  997. X        retval |= error_count;
  998. X        if (!retval)
  999. X        last_root = eval_root;
  1000. X        if (!last_root) {
  1001. X        Safefree(last_eval);
  1002. X        last_eval = Nullch;
  1003. X        }
  1004. X    }
  1005. X    else
  1006. X        retval = yyparse();
  1007. X    }
  1008. X    myroot = eval_root;        /* in case cmd_exec does another eval! */
  1009. X
  1010. X    if (retval) {
  1011. X    st = stack->ary_array;
  1012. X    sp = arglast[0];
  1013. X    if (gimme != G_ARRAY)
  1014. X        st[++sp] = &str_undef;
  1015. X    if (parsing) {
  1016. X#ifndef MANGLEDPARSE
  1017. X#ifdef DEBUGGING
  1018. X        if (debug & 128)
  1019. X        fprintf(stderr,"Freeing eval_root %lx\n",(long)eval_root);
  1020. X#endif
  1021. X        cmd_free(eval_root);
  1022. X#endif
  1023. X        if (eval_root == last_root)
  1024. X        last_root = Nullcmd;
  1025. X        eval_root = myroot = Nullcmd;
  1026. X    }
  1027. X    if (rsfp) {
  1028. X        fclose(rsfp);
  1029. X        rsfp = 0;
  1030. X    }
  1031. X    }
  1032. X    else {
  1033. X    parsing = 0;
  1034. X    sp = cmd_exec(eval_root,gimme,sp);
  1035. X    st = stack->ary_array;
  1036. X    for (i = arglast[0] + 1; i <= sp; i++)
  1037. X        st[i] = str_mortal(st[i]);
  1038. X                /* if we don't save result, free zaps it */
  1039. X    if (in_eval != 1 && myroot != last_root)
  1040. X        cmd_free(myroot);
  1041. X    }
  1042. X
  1043. X    perldb = oldperldb;
  1044. X    in_eval--;
  1045. X#ifdef DEBUGGING
  1046. X    if (debug & 4) {
  1047. X    char *tmps = loop_stack[loop_ptr].loop_label;
  1048. X    deb("(Popping label #%d %s)\n",loop_ptr,
  1049. X        tmps ? tmps : "" );
  1050. X    }
  1051. X#endif
  1052. X    loop_ptr--;
  1053. X    tmps_base = oldtmps_base;
  1054. X    curspat = oldspat;
  1055. X    lastspat = oldlspat;
  1056. X    if (savestack->ary_fill > oldsave)    /* let them use local() */
  1057. X    restorelist(oldsave);
  1058. X
  1059. X    if (optype != O_EVAL) {
  1060. X    if (retval) {
  1061. X        if (optype == O_REQUIRE)
  1062. X        fatal("%s", str_get(stab_val(stabent("@",TRUE))));
  1063. X    }
  1064. X    else {
  1065. X        curcmd = oldcurcmd;
  1066. X        if (gimme == G_SCALAR ? str_true(st[sp]) : sp > arglast[0]) {
  1067. X        (void)hstore(stab_hash(incstab), specfilename,
  1068. X          strlen(specfilename), str_smake(stab_val(curcmd->c_filestab)),
  1069. X              0 );
  1070. X        }
  1071. X        else if (optype == O_REQUIRE)
  1072. X        fatal("%s did not return a true value", specfilename);
  1073. X    }
  1074. X    }
  1075. X    curcmd = oldcurcmd;
  1076. X    return sp;
  1077. X}
  1078. X
  1079. X/* This routine handles any switches that can be given during run */
  1080. X
  1081. Xstatic char *
  1082. Xmoreswitches(s)
  1083. Xchar *s;
  1084. X{
  1085. X    int numlen;
  1086. X
  1087. X  reswitch:
  1088. X    switch (*s) {
  1089. X    case '0':
  1090. X    nrschar = scanoct(s, 4, &numlen);
  1091. X    nrs = nsavestr("\n",1);
  1092. X    *nrs = nrschar;
  1093. X    if (nrschar > 0377) {
  1094. X        nrslen = 0;
  1095. X        nrs = "";
  1096. X    }
  1097. X    else if (!nrschar && numlen >= 2) {
  1098. X        nrslen = 2;
  1099. X        nrs = "\n\n";
  1100. X        nrschar = '\n';
  1101. X    }
  1102. X    return s + numlen;
  1103. X    case 'a':
  1104. X    minus_a = TRUE;
  1105. X    s++;
  1106. X    return s;
  1107. X    case 'c':
  1108. X    minus_c = TRUE;
  1109. X    s++;
  1110. X    return s;
  1111. X    case 'd':
  1112. X#ifdef TAINT
  1113. X    if (euid != uid || egid != gid)
  1114. X        fatal("No -d allowed in setuid scripts");
  1115. X#endif
  1116. X    perldb = TRUE;
  1117. X    s++;
  1118. X    return s;
  1119. X    case 'D':
  1120. X#ifdef DEBUGGING
  1121. X#ifdef TAINT
  1122. X    if (euid != uid || egid != gid)
  1123. X        fatal("No -D allowed in setuid scripts");
  1124. X#endif
  1125. X    debug = atoi(s+1) | 32768;
  1126. X#else
  1127. X    warn("Recompile perl with -DDEBUGGING to use -D switch\n");
  1128. X#endif
  1129. X    for (s++; isdigit(*s); s++) ;
  1130. X    return s;
  1131. X    case 'i':
  1132. X    inplace = savestr(s+1);
  1133. X    for (s = inplace; *s && !isspace(*s); s++) ;
  1134. X    *s = '\0';
  1135. X    break;
  1136. X    case 'I':
  1137. X#ifdef TAINT
  1138. X    if (euid != uid || egid != gid)
  1139. X        fatal("No -I allowed in setuid scripts");
  1140. X#endif
  1141. X    if (*++s) {
  1142. X        (void)apush(stab_array(incstab),str_make(s,0));
  1143. X    }
  1144. X    else
  1145. X        fatal("No space allowed after -I");
  1146. X    break;
  1147. X    case 'l':
  1148. X    minus_l = TRUE;
  1149. X    s++;
  1150. X    if (isdigit(*s)) {
  1151. X        ors = savestr("\n");
  1152. X        orslen = 1;
  1153. X        *ors = scanoct(s, 3 + (*s == '0'), &numlen);
  1154. X        s += numlen;
  1155. X    }
  1156. X    else {
  1157. X        ors = nsavestr(nrs,nrslen);
  1158. X        orslen = nrslen;
  1159. X    }
  1160. X    return s;
  1161. X    case 'n':
  1162. X    minus_n = TRUE;
  1163. X    s++;
  1164. X    return s;
  1165. X    case 'p':
  1166. X    minus_p = TRUE;
  1167. X    s++;
  1168. X    return s;
  1169. X    case 'u':
  1170. X    do_undump = TRUE;
  1171. X    s++;
  1172. X    return s;
  1173. X    case 'U':
  1174. X    unsafe = TRUE;
  1175. X    s++;
  1176. X    return s;
  1177. X    case 'v':
  1178. X    fputs("\nThis is perl, version 4.0\n\n",stdout);
  1179. X    fputs(rcsid,stdout);
  1180. X    fputs("\nCopyright (c) 1989, 1990, 1991, Larry Wall\n",stdout);
  1181. X#ifdef MSDOS
  1182. X    fputs("MS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n",
  1183. X    stdout);
  1184. X#ifdef OS2
  1185. X        fputs("OS/2 port Copyright (c) 1990, Raymond Chen, Kai Uwe Rommel\n",
  1186. X        stdout);
  1187. X#endif
  1188. X#endif
  1189. X    fputs("\n\
  1190. XPerl may be copied only under the terms of the GNU General Public License,\n\
  1191. Xa copy of which can be found with the Perl 4.0 distribution kit.\n",stdout);
  1192. X#ifdef MSDOS
  1193. X        usage(origargv[0]);
  1194. X#endif
  1195. X    exit(0);
  1196. X    case 'w':
  1197. X    dowarn = TRUE;
  1198. X    s++;
  1199. X    return s;
  1200. X    case ' ':
  1201. X    case '\n':
  1202. X    case '\t':
  1203. X    break;
  1204. X    default:
  1205. X    fatal("Switch meaningless after -x: -%s",s);
  1206. X    }
  1207. X    return Nullch;
  1208. X}
  1209. X
  1210. X/* compliments of Tom Christiansen */
  1211. X
  1212. X/* unexec() can be found in the Gnu emacs distribution */
  1213. X
  1214. Xmy_unexec()
  1215. X{
  1216. X#ifdef UNEXEC
  1217. X    int    status;
  1218. X    extern int etext;
  1219. X    static char dumpname[BUFSIZ];
  1220. X    static char perlpath[256];
  1221. X
  1222. X    sprintf (dumpname, "%s.perldump", origfilename);
  1223. X    sprintf (perlpath, "%s/perl", BIN);
  1224. X
  1225. X    status = unexec(dumpname, perlpath, &etext, sbrk(0), 0);
  1226. X    if (status)
  1227. X    fprintf(stderr, "unexec of %s into %s failed!\n", perlpath, dumpname);
  1228. X    exit(status);
  1229. X#else
  1230. X#   ifndef SIGABRT
  1231. X#    define SIGABRT SIGILL
  1232. X#   endif
  1233. X#   ifndef SIGILL
  1234. X#    define SIGILL 6        /* blech */
  1235. X#   endif
  1236. X    kill(getpid(),SIGABRT);    /* for use with undump */
  1237. X#endif
  1238. X}
  1239. X
  1240. !STUFFY!FUNK!
  1241. echo Extracting emacs/perldb.pl
  1242. sed >emacs/perldb.pl <<'!STUFFY!FUNK!' -e 's/X//'
  1243. Xpackage DB;
  1244. X
  1245. X# modified Perl debugger, to be run from Emacs in perldb-mode
  1246. X# Ray Lischner (uunet!mntgfx!lisch) as of 5 Nov 1990
  1247. X
  1248. X$header = '$Header: perldb.pl,v 4.0 91/03/20 01:18:58 lwall Locked $';
  1249. X#
  1250. X# This file is automatically included if you do perl -d.
  1251. X# It's probably not useful to include this yourself.
  1252. X#
  1253. X# Perl supplies the values for @line and %sub.  It effectively inserts
  1254. X# a do DB'DB(<linenum>); in front of every place that can
  1255. X# have a breakpoint.  It also inserts a do 'perldb.pl' before the first line.
  1256. X#
  1257. X# $Log:    perldb.pl,v $
  1258. X# Revision 4.0  91/03/20  01:18:58  lwall
  1259. X# 4.0 baseline.
  1260. X# 
  1261. X# Revision 3.0.1.6  91/01/11  18:08:58  lwall
  1262. X# patch42: @_ couldn't be accessed from debugger
  1263. X# 
  1264. X# Revision 3.0.1.5  90/11/10  01:40:26  lwall
  1265. X# patch38: the debugger wouldn't stop correctly or do action routines
  1266. X# 
  1267. X# Revision 3.0.1.4  90/10/15  17:40:38  lwall
  1268. X# patch29: added caller
  1269. X# patch29: the debugger now understands packages and evals
  1270. X# patch29: scripts now run at almost full speed under the debugger
  1271. X# patch29: more variables are settable from debugger
  1272. X# 
  1273. X# Revision 3.0.1.3  90/08/09  04:00:58  lwall
  1274. X# patch19: debugger now allows continuation lines
  1275. X# patch19: debugger can now dump lists of variables
  1276. X# patch19: debugger can now add aliases easily from prompt
  1277. X# 
  1278. X# Revision 3.0.1.2  90/03/12  16:39:39  lwall
  1279. X# patch13: perl -d didn't format stack traces of *foo right
  1280. X# patch13: perl -d wiped out scalar return values of subroutines
  1281. X# 
  1282. X# Revision 3.0.1.1  89/10/26  23:14:02  lwall
  1283. X# patch1: RCS expanded an unintended $Header in lib/perldb.pl
  1284. X# 
  1285. X# Revision 3.0  89/10/18  15:19:46  lwall
  1286. X# 3.0 baseline
  1287. X# 
  1288. X# Revision 2.0  88/06/05  00:09:45  root
  1289. X# Baseline version 2.0.
  1290. X# 
  1291. X#
  1292. X
  1293. Xopen(IN, "</dev/tty") || open(IN,  "<&STDIN");    # so we don't dingle stdin
  1294. Xopen(OUT,">/dev/tty") || open(OUT, ">&STDOUT");    # so we don't dongle stdout
  1295. Xselect(OUT);
  1296. X$| = 1;                # for DB'OUT
  1297. Xselect(STDOUT);
  1298. X$| = 1;                # for real STDOUT
  1299. X$sub = '';
  1300. X
  1301. X# Is Perl being run from Emacs?
  1302. X$emacs = $main'ARGV[$[] eq '-emacs';
  1303. Xshift(@main'ARGV) if $emacs;
  1304. X
  1305. X$header =~ s/.Header: ([^,]+),v(\s+\S+\s+\S+).*$/$1$2/;
  1306. Xprint OUT "\nLoading DB routines from $header\n\nEnter h for help.\n\n";
  1307. X
  1308. Xsub DB {
  1309. X    &save;
  1310. X    ($package, $filename, $line) = caller;
  1311. X    $usercontext = '($@, $!, $[, $,, $/, $\) = @saved;' .
  1312. X    "package $package;";        # this won't let them modify, alas
  1313. X    local(*dbline) = "_<$filename";
  1314. X    $max = $#dbline;
  1315. X    if (($stop,$action) = split(/\0/,$dbline{$line})) {
  1316. X    if ($stop eq '1') {
  1317. X        $signal |= 1;
  1318. X    }
  1319. X    else {
  1320. X        $evalarg = "\$DB'signal |= do {$stop;}"; &eval;
  1321. X        $dbline{$line} =~ s/;9($|\0)/$1/;
  1322. X    }
  1323. X    }
  1324. X    if ($single || $trace || $signal) {
  1325. X    if ($emacs) {
  1326. X        print OUT "\032\032$filename:$line:0\n";
  1327. X    } else {
  1328. X        print OUT "$package'" unless $sub =~ /'/;
  1329. X        print OUT "$sub($filename:$line):\t",$dbline[$line];
  1330. X        for ($i = $line + 1; $i <= $max && $dbline[$i] == 0; ++$i) {
  1331. X        last if $dbline[$i] =~ /^\s*(}|#|\n)/;
  1332. X        print OUT "$sub($filename:$i):\t",$dbline[$i];
  1333. X        }
  1334. X    }
  1335. X    }
  1336. X    $evalarg = $action, &eval if $action;
  1337. X    if ($single || $signal) {
  1338. X    $evalarg = $pre, &eval if $pre;
  1339. X    print OUT $#stack . " levels deep in subroutine calls!\n"
  1340. X        if $single & 4;
  1341. X    $start = $line;
  1342. X    while ((print OUT "  DB<", $#hist+1, "> "), $cmd=&gets) {
  1343. X        $single = 0;
  1344. X        $signal = 0;
  1345. X        $cmd eq '' && exit 0;
  1346. X        chop($cmd);
  1347. X        $cmd =~ s/\\$// && do {
  1348. X        print OUT "  cont: ";
  1349. X        $cmd .= &gets;
  1350. X        redo;
  1351. X        };
  1352. X        $cmd =~ /^q$/ && exit 0;
  1353. X        $cmd =~ /^$/ && ($cmd = $laststep);
  1354. X        push(@hist,$cmd) if length($cmd) > 1;
  1355. X        ($i) = split(/\s+/,$cmd);
  1356. X        eval "\$cmd =~ $alias{$i}", print OUT $@ if $alias{$i};
  1357. X        $cmd =~ /^h$/ && do {
  1358. X        print OUT "
  1359. XT        Stack trace.
  1360. Xs        Single step.
  1361. Xn        Next, steps over subroutine calls.
  1362. Xr        Return from current subroutine.
  1363. Xc [line]    Continue; optionally inserts a one-time-only breakpoint 
  1364. X        at the specified line.
  1365. X<CR>        Repeat last n or s.
  1366. Xl min+incr    List incr+1 lines starting at min.
  1367. Xl min-max    List lines.
  1368. Xl line        List line;
  1369. Xl        List next window.
  1370. X-        List previous window.
  1371. Xw line        List window around line.
  1372. Xl subname    List subroutine.
  1373. Xf filename    Switch to filename.
  1374. X/pattern/    Search forwards for pattern; final / is optional.
  1375. X?pattern?    Search backwards for pattern.
  1376. XL        List breakpoints and actions.
  1377. XS        List subroutine names.
  1378. Xt        Toggle trace mode.
  1379. Xb [line] [condition]
  1380. X        Set breakpoint; line defaults to the current execution line; 
  1381. X        condition breaks if it evaluates to true, defaults to \'1\'.
  1382. Xb subname [condition]
  1383. X        Set breakpoint at first line of subroutine.
  1384. Xd [line]    Delete breakpoint.
  1385. XD        Delete all breakpoints.
  1386. Xa [line] command
  1387. X        Set an action to be done before the line is executed.
  1388. X        Sequence is: check for breakpoint, print line if necessary,
  1389. X        do action, prompt user if breakpoint or step, evaluate line.
  1390. XA        Delete all actions.
  1391. XV [pkg [vars]]    List some (default all) variables in package (default current).
  1392. XX [vars]    Same as \"V currentpackage [vars]\".
  1393. X< command    Define command before prompt.
  1394. X| command    Define command after prompt.
  1395. X! number    Redo command (default previous command).
  1396. X! -number    Redo number\'th to last command.
  1397. XH -number    Display last number commands (default all).
  1398. Xq or ^D        Quit.
  1399. Xp expr        Same as \"print DB'OUT expr\" in current package.
  1400. X= [alias value]    Define a command alias, or list current aliases.
  1401. Xcommand        Execute as a perl statement in current package.
  1402. X
  1403. X";
  1404. X        next; };
  1405. X        $cmd =~ /^t$/ && do {
  1406. X        $trace = !$trace;
  1407. X        print OUT "Trace = ".($trace?"on":"off")."\n";
  1408. X        next; };
  1409. X        $cmd =~ /^S$/ && do {
  1410. X        foreach $subname (sort(keys %sub)) {
  1411. X            print OUT $subname,"\n";
  1412. X        }
  1413. X        next; };
  1414. X        $cmd =~ s/^X\b/V $package/;
  1415. X        $cmd =~ /^V$/ && do {
  1416. X        $cmd = 'V $package'; };
  1417. X        $cmd =~ /^V\s*(\S+)\s*(.*)/ && do {
  1418. X        $packname = $1;
  1419. X        @vars = split(' ',$2);
  1420. X        do 'dumpvar.pl' unless defined &main'dumpvar;
  1421. X        if (defined &main'dumpvar) {
  1422. X            &main'dumpvar($packname,@vars);
  1423. X        }
  1424. X        else {
  1425. X            print DB'OUT "dumpvar.pl not available.\n";
  1426. X        }
  1427. X        next; };
  1428. X        $cmd =~ /^f\s*(.*)/ && do {
  1429. X        $file = $1;
  1430. X        if (!$file) {
  1431. X            print OUT "The old f command is now the r command.\n";
  1432. X            print OUT "The new f command switches filenames.\n";
  1433. X            next;
  1434. X        }
  1435. X        if (!defined $_main{'_<' . $file}) {
  1436. X            if (($try) = grep(m#^_<.*$file#, keys %_main)) {
  1437. X            $file = substr($try,2);
  1438. X            print "\n$file:\n";
  1439. X            }
  1440. X        }
  1441. X        if (!defined $_main{'_<' . $file}) {
  1442. X            print OUT "There's no code here anything matching $file.\n";
  1443. X            next;
  1444. X        }
  1445. X        elsif ($file ne $filename) {
  1446. X            *dbline = "_<$file";
  1447. X            $max = $#dbline;
  1448. X            $filename = $file;
  1449. X            $start = 1;
  1450. X            $cmd = "l";
  1451. X        } };
  1452. X        $cmd =~ /^l\s*(['A-Za-z_]['\w]*)/ && do {
  1453. X        $subname = $1;
  1454. X        $subname = "main'" . $subname unless $subname =~ /'/;
  1455. X        $subname = "main" . $subname if substr($subname,0,1) eq "'";
  1456. X        ($file,$subrange) = split(/:/,$sub{$subname});
  1457. X        if ($file ne $filename) {
  1458. X            *dbline = "_<$file";
  1459. X            $max = $#dbline;
  1460. X            $filename = $file;
  1461. X        }
  1462. X        if ($subrange) {
  1463. X            if (eval($subrange) < -$window) {
  1464. X            $subrange =~ s/-.*/+/;
  1465. X            }
  1466. X            $cmd = "l $subrange";
  1467. X        } else {
  1468. X            print OUT "Subroutine $1 not found.\n";
  1469. X            next;
  1470. X        } };
  1471. X        $cmd =~ /^w\s*(\d*)$/ && do {
  1472. X        $incr = $window - 1;
  1473. X        $start = $1 if $1;
  1474. X        $start -= $preview;
  1475. X        $cmd = 'l ' . $start . '-' . ($start + $incr); };
  1476. X        $cmd =~ /^-$/ && do {
  1477. X        $incr = $window - 1;
  1478. X        $cmd = 'l ' . ($start-$window*2) . '+'; };
  1479. X        $cmd =~ /^l$/ && do {
  1480. X        $incr = $window - 1;
  1481. X        $cmd = 'l ' . $start . '-' . ($start + $incr); };
  1482. X        $cmd =~ /^l\s*(\d*)\+(\d*)$/ && do {
  1483. X        $start = $1 if $1;
  1484. X        $incr = $2;
  1485. X        $incr = $window - 1 unless $incr;
  1486. X        $cmd = 'l ' . $start . '-' . ($start + $incr); };
  1487. X        $cmd =~ /^l\s*(([\d\$\.]+)([-,]([\d\$\.]+))?)?/ && do {
  1488. X        $end = (!$2) ? $max : ($4 ? $4 : $2);
  1489. X        $end = $max if $end > $max;
  1490. X        $i = $2;
  1491. X        $i = $line if $i eq '.';
  1492. X        $i = 1 if $i < 1;
  1493. X        if ($emacs) {
  1494. X            print OUT "\032\032$filename:$i:0\n";
  1495. X            $i = $end;
  1496. X        } else {
  1497. X            for (; $i <= $end; $i++) {
  1498. X            print OUT "$i:\t", $dbline[$i];
  1499. X            last if $signal;
  1500. X            }
  1501. X        }
  1502. X        $start = $i;    # remember in case they want more
  1503. X        $start = $max if $start > $max;
  1504. X        next; };
  1505. X        $cmd =~ /^D$/ && do {
  1506. X        print OUT "Deleting all breakpoints...\n";
  1507. X        for ($i = 1; $i <= $max ; $i++) {
  1508. X            if (defined $dbline{$i}) {
  1509. X            $dbline{$i} =~ s/^[^\0]+//;
  1510. X            if ($dbline{$i} =~ s/^\0?$//) {
  1511. X                delete $dbline{$i};
  1512. X            }
  1513. X            }
  1514. X        }
  1515. X        next; };
  1516. X        $cmd =~ /^L$/ && do {
  1517. X        for ($i = 1; $i <= $max; $i++) {
  1518. X            if (defined $dbline{$i}) {
  1519. X            print OUT "$i:\t", $dbline[$i];
  1520. X            ($stop,$action) = split(/\0/, $dbline{$i});
  1521. X            print OUT "  break if (", $stop, ")\n" 
  1522. X                if $stop;
  1523. X            print OUT "  action:  ", $action, "\n" 
  1524. X                if $action;
  1525. X            last if $signal;
  1526. X            }
  1527. X        }
  1528. X        next; };
  1529. X        $cmd =~ /^b\s*(['A-Za-z_]['\w]*)\s*(.*)/ && do {
  1530. X        $subname = $1;
  1531. X        $cond = $2 || '1';
  1532. X        $subname = "$package'" . $subname unless $subname =~ /'/;
  1533. X        $subname = "main" . $subname if substr($subname,0,1) eq "'";
  1534. X        ($filename,$i) = split(/[:-]/, $sub{$subname});
  1535. X        if ($i) {
  1536. X            *dbline = "_<$filename";
  1537. X            ++$i while $dbline[$i] == 0 && $i < $#dbline;
  1538. X            $dbline{$i} =~ s/^[^\0]*/$cond/;
  1539. X        } else {
  1540. X            print OUT "Subroutine $subname not found.\n";
  1541. X        }
  1542. X        next; };
  1543. X        $cmd =~ /^b\s*(\d*)\s*(.*)/ && do {
  1544. X        $i = ($1?$1:$line);
  1545. X        $cond = $2 || '1';
  1546. X        if ($dbline[$i] == 0) {
  1547. X            print OUT "Line $i not breakable.\n";
  1548. X        } else {
  1549. X            $dbline{$i} =~ s/^[^\0]*/$cond/;
  1550. X        }
  1551. X        next; };
  1552. X        $cmd =~ /^d\s*(\d+)?/ && do {
  1553. X        $i = ($1?$1:$line);
  1554. X        $dbline{$i} =~ s/^[^\0]*//;
  1555. X        delete $dbline{$i} if $dbline{$i} eq '';
  1556. X        next; };
  1557. X        $cmd =~ /^A$/ && do {
  1558. X        for ($i = 1; $i <= $max ; $i++) {
  1559. X            if (defined $dbline{$i}) {
  1560. X            $dbline{$i} =~ s/\0[^\0]*//;
  1561. X            delete $dbline{$i} if $dbline{$i} eq '';
  1562. X            }
  1563. X        }
  1564. X        next; };
  1565. X        $cmd =~ /^<\s*(.*)/ && do {
  1566. X        $pre = do action($1);
  1567. X        next; };
  1568. X        $cmd =~ /^>\s*(.*)/ && do {
  1569. X        $post = do action($1);
  1570. X        next; };
  1571. X        $cmd =~ /^a\s*(\d+)(\s+(.*))?/ && do {
  1572. X        $i = $1;
  1573. X        if ($dbline[$i] == 0) {
  1574. X            print OUT "Line $i may not have an action.\n";
  1575. X        } else {
  1576. X            $dbline{$i} =~ s/\0[^\0]*//;
  1577. X            $dbline{$i} .= "\0" . do action($3);
  1578. X        }
  1579. X        next; };
  1580. X        $cmd =~ /^n$/ && do {
  1581. X        $single = 2;
  1582. X        $laststep = $cmd;
  1583. X        last; };
  1584. X        $cmd =~ /^s$/ && do {
  1585. X        $single = 1;
  1586. X        $laststep = $cmd;
  1587. X        last; };
  1588. X        $cmd =~ /^c\s*(\d*)\s*$/ && do {
  1589. X        $i = $1;
  1590. X        if ($i) {
  1591. X            if ($dbline[$i] == 0) {
  1592. X                print OUT "Line $i not breakable.\n";
  1593. X            next;
  1594. X            }
  1595. X            $dbline{$i} =~ s/(\0|$)/;9$1/;    # add one-time-only b.p.
  1596. X        }
  1597. X        for ($i=0; $i <= $#stack; ) {
  1598. X            $stack[$i++] &= ~1;
  1599. X        }
  1600. X        last; };
  1601. X        $cmd =~ /^r$/ && do {
  1602. X        $stack[$#stack] |= 2;
  1603. X        last; };
  1604. X        $cmd =~ /^T$/ && do {
  1605. X        local($p,$f,$l,$s,$h,$a,@a,@sub);
  1606. X        for ($i = 1; ($p,$f,$l,$s,$h,$w) = caller($i); $i++) {
  1607. X            @a = @args;
  1608. X            for (@a) {
  1609. X            if (/^StB\000/ && length($_) == length($_main{'_main'})) {
  1610. X                $_ = sprintf("%s",$_);
  1611. X            }
  1612. X            else {
  1613. X                s/'/\\'/g;
  1614. X                s/([^\0]*)/'$1'/ unless /^-?[\d.]+$/;
  1615. X                s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
  1616. X                s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
  1617. X            }
  1618. X            }
  1619. X            $w = $w ? '@ = ' : '$ = ';
  1620. X            $a = $h ? '(' . join(', ', @a) . ')' : '';
  1621. X            push(@sub, "$w&$s$a from file $f line $l\n");
  1622. X            last if $signal;
  1623. X        }
  1624. X        for ($i=0; $i <= $#sub; $i++) {
  1625. X            last if $signal;
  1626. X            print OUT $sub[$i];
  1627. X        }
  1628. X            next; };
  1629. X        $cmd =~ /^\/(.*)$/ && do {
  1630. X        $inpat = $1;
  1631. X        $inpat =~ s:([^\\])/$:$1:;
  1632. X        if ($inpat ne "") {
  1633. X            eval '$inpat =~ m'."\n$inpat\n";    
  1634. X            if ($@ ne "") {
  1635. X                print OUT "$@";
  1636. X                next;
  1637. X            }
  1638. X            $pat = $inpat;
  1639. X        }
  1640. X        $end = $start;
  1641. X        eval '
  1642. X        for (;;) {
  1643. X            ++$start;
  1644. X            $start = 1 if ($start > $max);
  1645. X            last if ($start == $end);
  1646. X            if ($dbline[$start] =~ m'."\n$pat\n".'i) {
  1647. X            if ($emacs) {
  1648. X                print OUT "\032\032$filename:$start:0\n";
  1649. X            } else {
  1650. X                print OUT "$start:\t", $dbline[$start], "\n";
  1651. X            }
  1652. X            last;
  1653. X            }
  1654. X        } ';
  1655. X        print OUT "/$pat/: not found\n" if ($start == $end);
  1656. X        next; };
  1657. X        $cmd =~ /^\?(.*)$/ && do {
  1658. X        $inpat = $1;
  1659. X        $inpat =~ s:([^\\])\?$:$1:;
  1660. X        if ($inpat ne "") {
  1661. X            eval '$inpat =~ m'."\n$inpat\n";    
  1662. X            if ($@ ne "") {
  1663. X                print OUT "$@";
  1664. X                next;
  1665. X            }
  1666. X            $pat = $inpat;
  1667. X        }
  1668. X        $end = $start;
  1669. X        eval '
  1670. X        for (;;) {
  1671. X            --$start;
  1672. X            $start = $max if ($start <= 0);
  1673. X            last if ($start == $end);
  1674. X            if ($dbline[$start] =~ m'."\n$pat\n".'i) {
  1675. X            if ($emacs) {
  1676. X                print OUT "\032\032$filename:$start:0\n";
  1677. X            } else {
  1678. X                print OUT "$start:\t", $dbline[$start], "\n";
  1679. X            }
  1680. X            last;
  1681. X            }
  1682. X        } ';
  1683. X        print OUT "?$pat?: not found\n" if ($start == $end);
  1684. X        next; };
  1685. X        $cmd =~ /^!+\s*(-)?(\d+)?$/ && do {
  1686. X        pop(@hist) if length($cmd) > 1;
  1687. X        $i = ($1?($#hist-($2?$2:1)):($2?$2:$#hist));
  1688. X        $cmd = $hist[$i] . "\n";
  1689. X        print OUT $cmd;
  1690. X        redo; };
  1691. X        $cmd =~ /^!(.+)$/ && do {
  1692. X        $pat = "^$1";
  1693. X        pop(@hist) if length($cmd) > 1;
  1694. X        for ($i = $#hist; $i; --$i) {
  1695. X            last if $hist[$i] =~ $pat;
  1696. X        }
  1697. X        if (!$i) {
  1698. X            print OUT "No such command!\n\n";
  1699. X            next;
  1700. X        }
  1701. X        $cmd = $hist[$i] . "\n";
  1702. X        print OUT $cmd;
  1703. X        redo; };
  1704. X        $cmd =~ /^H\s*(-(\d+))?/ && do {
  1705. X        $end = $2?($#hist-$2):0;
  1706. X        $hist = 0 if $hist < 0;
  1707. X        for ($i=$#hist; $i>$end; $i--) {
  1708. X            print OUT "$i: ",$hist[$i],"\n"
  1709. X            unless $hist[$i] =~ /^.?$/;
  1710. X        };
  1711. X        next; };
  1712. X        $cmd =~ s/^p( .*)?$/print DB'OUT$1/;
  1713. X        $cmd =~ /^=/ && do {
  1714. X        if (local($k,$v) = ($cmd =~ /^=\s*(\S+)\s+(.*)/)) {
  1715. X            $alias{$k}="s~$k~$v~";
  1716. X            print OUT "$k = $v\n";
  1717. X        } elsif ($cmd =~ /^=\s*$/) {
  1718. X            foreach $k (sort keys(%alias)) {
  1719. X            if (($v = $alias{$k}) =~ s~^s\~$k\~(.*)\~$~$1~) {
  1720. X                print OUT "$k = $v\n";
  1721. X            } else {
  1722. X                print OUT "$k\t$alias{$k}\n";
  1723. X            };
  1724. X            };
  1725. X        };
  1726. X        next; };
  1727. X        $evalarg = $cmd; &eval;
  1728. X        print OUT "\n";
  1729. X    }
  1730. X    if ($post) {
  1731. X        $evalarg = $post; &eval;
  1732. X    }
  1733. X    }
  1734. X    ($@, $!, $[, $,, $/, $\) = @saved;
  1735. X}
  1736. X
  1737. Xsub save {
  1738. X    @saved = ($@, $!, $[, $,, $/, $\);
  1739. X    $[ = 0; $, = ""; $/ = "\n"; $\ = "";
  1740. X}
  1741. X
  1742. X# The following takes its argument via $evalarg to preserve current @_
  1743. X
  1744. Xsub eval {
  1745. X    eval "$usercontext $evalarg; &DB'save";
  1746. X    print OUT $@;
  1747. X}
  1748. X
  1749. Xsub action {
  1750. X    local($action) = @_;
  1751. X    while ($action =~ s/\\$//) {
  1752. X    print OUT "+ ";
  1753. X    $action .= &gets;
  1754. X    }
  1755. X    $action;
  1756. X}
  1757. X
  1758. Xsub gets {
  1759. X    local($.);
  1760. X    <IN>;
  1761. X}
  1762. X
  1763. Xsub catch {
  1764. X    $signal = 1;
  1765. X}
  1766. X
  1767. Xsub sub {
  1768. X    push(@stack, $single);
  1769. X    $single &= 1;
  1770. X    $single |= 4 if $#stack == $deep;
  1771. X    if (wantarray) {
  1772. X    @i = &$sub;
  1773. X    $single |= pop(@stack);
  1774. X    @i;
  1775. X    }
  1776. X    else {
  1777. X    $i = &$sub;
  1778. X    $single |= pop(@stack);
  1779. X    $i;
  1780. X    }
  1781. X}
  1782. X
  1783. X$single = 1;            # so it stops on first executable statement
  1784. X@hist = ('?');
  1785. X$SIG{'INT'} = "DB'catch";
  1786. X$deep = 100;        # warning if stack gets this deep
  1787. X$window = 10;
  1788. X$preview = 3;
  1789. X
  1790. X@stack = (0);
  1791. X@ARGS = @ARGV;
  1792. Xfor (@args) {
  1793. X    s/'/\\'/g;
  1794. X    s/(.*)/'$1'/ unless /^-?[\d.]+$/;
  1795. X}
  1796. X
  1797. Xif (-f '.perldb') {
  1798. X    do './.perldb';
  1799. X}
  1800. Xelsif (-f "$ENV{'LOGDIR'}/.perldb") {
  1801. X    do "$ENV{'LOGDIR'}/.perldb";
  1802. X}
  1803. Xelsif (-f "$ENV{'HOME'}/.perldb") {
  1804. X    do "$ENV{'HOME'}/.perldb";
  1805. X}
  1806. X
  1807. X1;
  1808. !STUFFY!FUNK!
  1809. echo Extracting perlsh
  1810. sed >perlsh <<'!STUFFY!FUNK!' -e 's/X//'
  1811. X#!/usr/bin/perl
  1812. X
  1813. X# Poor man's perl shell.
  1814. X
  1815. X# Simply type two carriage returns every time you want to evaluate.
  1816. X# Note that it must be a complete perl statement--don't type double
  1817. X#  carriage return in the middle of a loop.
  1818. X
  1819. X$/ = '';    # set paragraph mode
  1820. X$SHlinesep = "\n";
  1821. Xwhile ($SHcmd = <>) {
  1822. X    $/ = $SHlinesep;
  1823. X    eval $SHcmd; print $@ || "\n";
  1824. X    $SHlinesep = $/; $/ = '';
  1825. X}
  1826. !STUFFY!FUNK!
  1827. echo " "
  1828. echo "End of kit 16 (of 36)"
  1829. cat /dev/null >kit16isdone
  1830. run=''
  1831. config=''
  1832. for iskit in 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36; do
  1833.     if test -f kit${iskit}isdone; then
  1834.     run="$run $iskit"
  1835.     else
  1836.     todo="$todo $iskit"
  1837.     fi
  1838. done
  1839. case $todo in
  1840.     '')
  1841.     echo "You have run all your kits.  Please read README and then type Configure."
  1842.     for combo in *:AA; do
  1843.         if test -f "$combo"; then
  1844.         realfile=`basename $combo :AA`
  1845.         cat $realfile:[A-Z][A-Z] >$realfile
  1846.         rm -rf $realfile:[A-Z][A-Z]
  1847.         fi
  1848.     done
  1849.     rm -rf kit*isdone
  1850.     chmod 755 Configure
  1851.     ;;
  1852.     *)  echo "You have run$run."
  1853.     echo "You still need to run$todo."
  1854.     ;;
  1855. esac
  1856. : Someone might mail this, so...
  1857. exit
  1858.  
  1859. exit 0 # Just in case...
  1860. -- 
  1861. Kent Landfield                   INTERNET: kent@sparky.IMD.Sterling.COM
  1862. Sterling Software, IMD           UUCP:     uunet!sparky!kent
  1863. Phone:    (402) 291-8300         FAX:      (402) 291-4362
  1864. Please send comp.sources.misc-related mail to kent@uunet.uu.net.
  1865.