home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1994 October / usenetsourcesnewsgroupsinfomagicoctober1994disk2.iso / unix / volume20 / perl3.0 / part17 < prev    next >
Text File  |  1989-11-01  |  50KB  |  2,113 lines

  1. Subject:  v20i100:  Perl, a language with features of C/sed/awk/shell/etc, Part17/24
  2. Newsgroups: comp.sources.unix
  3. Sender: sources
  4. Approved: rsalz@uunet.UU.NET
  5.  
  6. Submitted-by: Larry Wall <lwall@jpl-devvax.jpl.nasa.gov>
  7. Posting-number: Volume 20, Issue 100
  8. Archive-name: perl3.0/part17
  9.  
  10. #! /bin/sh
  11.  
  12. # Make a new directory for the perl sources, cd to it, and run kits 1
  13. # thru 24 through sh.  When all 24 kits have been run, read README.
  14.  
  15. echo "This is perl 3.0 kit 17 (of 24).  If kit 17 is complete, the line"
  16. echo '"'"End of kit 17 (of 24)"'" will echo at the end.'
  17. echo ""
  18. export PATH || (echo "You didn't use sh, you clunch." ; kill $$)
  19. mkdir eg 2>/dev/null
  20. echo Extracting util.c
  21. sed >util.c <<'!STUFFY!FUNK!' -e 's/X//'
  22. X/* $Header: util.c,v 3.0 89/10/18 15:32:43 lwall Locked $
  23. X *
  24. X *    Copyright (c) 1989, Larry Wall
  25. X *
  26. X *    You may distribute under the terms of the GNU General Public License
  27. X *    as specified in the README file that comes with the perl 3.0 kit.
  28. X *
  29. X * $Log:    util.c,v $
  30. X * Revision 3.0  89/10/18  15:32:43  lwall
  31. X * 3.0 baseline
  32. X * 
  33. X */
  34. X
  35. X#include "EXTERN.h"
  36. X#include "perl.h"
  37. X#include "errno.h"
  38. X#include <signal.h>
  39. X
  40. X#ifdef I_VFORK
  41. X#  include <vfork.h>
  42. X#endif
  43. X
  44. X#ifdef I_VARARGS
  45. X#  include <varargs.h>
  46. X#endif
  47. X
  48. X#define FLUSH
  49. X
  50. Xstatic char nomem[] = "Out of memory!\n";
  51. X
  52. X/* paranoid version of malloc */
  53. X
  54. X#ifdef DEBUGGING
  55. Xstatic int an = 0;
  56. X#endif
  57. X
  58. X/* NOTE:  Do not call the next three routines directly.  Use the macros
  59. X * in handy.h, so that we can easily redefine everything to do tracking of
  60. X * allocated hunks back to the original New to track down any memory leaks.
  61. X */
  62. X
  63. Xchar *
  64. Xsafemalloc(size)
  65. XMEM_SIZE size;
  66. X{
  67. X    char *ptr;
  68. X    char *malloc();
  69. X
  70. X    ptr = malloc(size?size:1);    /* malloc(0) is NASTY on our system */
  71. X#ifdef DEBUGGING
  72. X#  ifndef I286
  73. X    if (debug & 128)
  74. X    fprintf(stderr,"0x%x: (%05d) malloc %d bytes\n",ptr,an++,size);
  75. X#  else
  76. X    if (debug & 128)
  77. X    fprintf(stderr,"0x%lx: (%05d) malloc %d bytes\n",ptr,an++,size);
  78. X#  endif
  79. X#endif
  80. X    if (ptr != Nullch)
  81. X    return ptr;
  82. X    else {
  83. X    fputs(nomem,stdout) FLUSH;
  84. X    exit(1);
  85. X    }
  86. X    /*NOTREACHED*/
  87. X#ifdef lint
  88. X    return ptr;
  89. X#endif
  90. X}
  91. X
  92. X/* paranoid version of realloc */
  93. X
  94. Xchar *
  95. Xsaferealloc(where,size)
  96. Xchar *where;
  97. XMEM_SIZE size;
  98. X{
  99. X    char *ptr;
  100. X    char *realloc();
  101. X
  102. X    if (!where)
  103. X    fatal("Null realloc");
  104. X    ptr = realloc(where,size?size:1);    /* realloc(0) is NASTY on our system */
  105. X#ifdef DEBUGGING
  106. X#  ifndef I286
  107. X    if (debug & 128) {
  108. X    fprintf(stderr,"0x%x: (%05d) rfree\n",where,an++);
  109. X    fprintf(stderr,"0x%x: (%05d) realloc %d bytes\n",ptr,an++,size);
  110. X    }
  111. X#  else
  112. X    if (debug & 128) {
  113. X    fprintf(stderr,"0x%lx: (%05d) rfree\n",where,an++);
  114. X    fprintf(stderr,"0x%lx: (%05d) realloc %d bytes\n",ptr,an++,size);
  115. X    }
  116. X#  endif
  117. X#endif
  118. X    if (ptr != Nullch)
  119. X    return ptr;
  120. X    else {
  121. X    fputs(nomem,stdout) FLUSH;
  122. X    exit(1);
  123. X    }
  124. X    /*NOTREACHED*/
  125. X#ifdef lint
  126. X    return ptr;
  127. X#endif
  128. X}
  129. X
  130. X/* safe version of free */
  131. X
  132. Xvoid
  133. Xsafefree(where)
  134. Xchar *where;
  135. X{
  136. X#ifdef DEBUGGING
  137. X#  ifndef I286
  138. X    if (debug & 128)
  139. X    fprintf(stderr,"0x%x: (%05d) free\n",where,an++);
  140. X#  else
  141. X    if (debug & 128)
  142. X    fprintf(stderr,"0x%lx: (%05d) free\n",where,an++);
  143. X#  endif
  144. X#endif
  145. X    if (where) {
  146. X    free(where);
  147. X    }
  148. X}
  149. X
  150. X#ifdef LEAKTEST
  151. X
  152. X#define ALIGN sizeof(long)
  153. X
  154. Xchar *
  155. Xsafexmalloc(x,size)
  156. Xint x;
  157. XMEM_SIZE size;
  158. X{
  159. X    register char *where;
  160. X
  161. X    where = safemalloc(size + ALIGN);
  162. X    xcount[x]++;
  163. X    where[0] = x % 100;
  164. X    where[1] = x / 100;
  165. X    return where + ALIGN;
  166. X}
  167. X
  168. Xchar *
  169. Xsafexrealloc(where,size)
  170. Xchar *where;
  171. XMEM_SIZE size;
  172. X{
  173. X    return saferealloc(where - ALIGN, size + ALIGN) + ALIGN;
  174. X}
  175. X
  176. Xvoid
  177. Xsafexfree(where)
  178. Xchar *where;
  179. X{
  180. X    int x;
  181. X
  182. X    if (!where)
  183. X    return;
  184. X    where -= ALIGN;
  185. X    x = where[0] + 100 * where[1];
  186. X    xcount[x]--;
  187. X    safefree(where);
  188. X}
  189. X
  190. Xxstat()
  191. X{
  192. X    register int i;
  193. X
  194. X    for (i = 0; i < MAXXCOUNT; i++) {
  195. X    if (xcount[i] != lastxcount[i]) {
  196. X        fprintf(stderr,"%2d %2d\t%ld\n", i / 100, i % 100, xcount[i]);
  197. X        lastxcount[i] = xcount[i];
  198. X    }
  199. X    }
  200. X}
  201. X
  202. X#endif /* LEAKTEST */
  203. X
  204. X/* copy a string up to some (non-backslashed) delimiter, if any */
  205. X
  206. Xchar *
  207. Xcpytill(to,from,fromend,delim,retlen)
  208. Xregister char *to, *from;
  209. Xregister char *fromend;
  210. Xregister int delim;
  211. Xint *retlen;
  212. X{
  213. X    char *origto = to;
  214. X
  215. X    for (; from < fromend; from++,to++) {
  216. X    if (*from == '\\') {
  217. X        if (from[1] == delim)
  218. X        from++;
  219. X        else if (from[1] == '\\')
  220. X        *to++ = *from++;
  221. X    }
  222. X    else if (*from == delim)
  223. X        break;
  224. X    *to = *from;
  225. X    }
  226. X    *to = '\0';
  227. X    *retlen = to - origto;
  228. X    return from;
  229. X}
  230. X
  231. X/* return ptr to little string in big string, NULL if not found */
  232. X/* This routine was donated by Corey Satten. */
  233. X
  234. Xchar *
  235. Xinstr(big, little)
  236. Xregister char *big;
  237. Xregister char *little;
  238. X{
  239. X    register char *s, *x;
  240. X    register int first;
  241. X
  242. X    if (!little)
  243. X    return big;
  244. X    first = *little++;
  245. X    if (!first)
  246. X    return big;
  247. X    while (*big) {
  248. X    if (*big++ != first)
  249. X        continue;
  250. X    for (x=big,s=little; *s; /**/ ) {
  251. X        if (!*x)
  252. X        return Nullch;
  253. X        if (*s++ != *x++) {
  254. X        s--;
  255. X        break;
  256. X        }
  257. X    }
  258. X    if (!*s)
  259. X        return big-1;
  260. X    }
  261. X    return Nullch;
  262. X}
  263. X
  264. X/* same as instr but allow embedded nulls */
  265. X
  266. Xchar *
  267. Xninstr(big, bigend, little, lend)
  268. Xregister char *big;
  269. Xregister char *bigend;
  270. Xchar *little;
  271. Xchar *lend;
  272. X{
  273. X    register char *s, *x;
  274. X    register int first = *little;
  275. X    register char *littleend = lend;
  276. X
  277. X    if (!first && little > littleend)
  278. X    return big;
  279. X    bigend -= littleend - little++;
  280. X    while (big <= bigend) {
  281. X    if (*big++ != first)
  282. X        continue;
  283. X    for (x=big,s=little; s < littleend; /**/ ) {
  284. X        if (*s++ != *x++) {
  285. X        s--;
  286. X        break;
  287. X        }
  288. X    }
  289. X    if (s >= littleend)
  290. X        return big-1;
  291. X    }
  292. X    return Nullch;
  293. X}
  294. X
  295. X/* reverse of the above--find last substring */
  296. X
  297. Xchar *
  298. Xrninstr(big, bigend, little, lend)
  299. Xregister char *big;
  300. Xchar *bigend;
  301. Xchar *little;
  302. Xchar *lend;
  303. X{
  304. X    register char *bigbeg;
  305. X    register char *s, *x;
  306. X    register int first = *little;
  307. X    register char *littleend = lend;
  308. X
  309. X    if (!first && little > littleend)
  310. X    return bigend;
  311. X    bigbeg = big;
  312. X    big = bigend - (littleend - little++);
  313. X    while (big >= bigbeg) {
  314. X    if (*big-- != first)
  315. X        continue;
  316. X    for (x=big+2,s=little; s < littleend; /**/ ) {
  317. X        if (*s++ != *x++) {
  318. X        s--;
  319. X        break;
  320. X        }
  321. X    }
  322. X    if (s >= littleend)
  323. X        return big+1;
  324. X    }
  325. X    return Nullch;
  326. X}
  327. X
  328. Xunsigned char fold[] = {
  329. X    0,    1,    2,    3,    4,    5,    6,    7,
  330. X    8,    9,    10,    11,    12,    13,    14,    15,
  331. X    16,    17,    18,    19,    20,    21,    22,    23,
  332. X    24,    25,    26,    27,    28,    29,    30,    31,
  333. X    32,    33,    34,    35,    36,    37,    38,    39,
  334. X    40,    41,    42,    43,    44,    45,    46,    47,
  335. X    48,    49,    50,    51,    52,    53,    54,    55,
  336. X    56,    57,    58,    59,    60,    61,    62,    63,
  337. X    64,    'a',    'b',    'c',    'd',    'e',    'f',    'g',
  338. X    'h',    'i',    'j',    'k',    'l',    'm',    'n',    'o',
  339. X    'p',    'q',    'r',    's',    't',    'u',    'v',    'w',
  340. X    'x',    'y',    'z',    91,    92,    93,    94,    95,
  341. X    96,    'A',    'B',    'C',    'D',    'E',    'F',    'G',
  342. X    'H',    'I',    'J',    'K',    'L',    'M',    'N',    'O',
  343. X    'P',    'Q',    'R',    'S',    'T',    'U',    'V',    'W',
  344. X    'X',    'Y',    'Z',    123,    124,    125,    126,    127,
  345. X    128,    129,    130,    131,    132,    133,    134,    135,
  346. X    136,    137,    138,    139,    140,    141,    142,    143,
  347. X    144,    145,    146,    147,    148,    149,    150,    151,
  348. X    152,    153,    154,    155,    156,    157,    158,    159,
  349. X    160,    161,    162,    163,    164,    165,    166,    167,
  350. X    168,    169,    170,    171,    172,    173,    174,    175,
  351. X    176,    177,    178,    179,    180,    181,    182,    183,
  352. X    184,    185,    186,    187,    188,    189,    190,    191,
  353. X    192,    193,    194,    195,    196,    197,    198,    199,
  354. X    200,    201,    202,    203,    204,    205,    206,    207,
  355. X    208,    209,    210,    211,    212,    213,    214,    215,
  356. X    216,    217,    218,    219,    220,    221,    222,    223,    
  357. X    224,    225,    226,    227,    228,    229,    230,    231,
  358. X    232,    233,    234,    235,    236,    237,    238,    239,
  359. X    240,    241,    242,    243,    244,    245,    246,    247,
  360. X    248,    249,    250,    251,    252,    253,    254,    255
  361. X};
  362. X
  363. Xstatic unsigned char freq[] = {
  364. X    1,    2,    84,    151,    154,    155,    156,    157,
  365. X    165,    246,    250,    3,    158,    7,    18,    29,
  366. X    40,    51,    62,    73,    85,    96,    107,    118,
  367. X    129,    140,    147,    148,    149,    150,    152,    153,
  368. X    255,    182,    224,    205,    174,    176,    180,    217,
  369. X    233,    232,    236,    187,    235,    228,    234,    226,
  370. X    222,    219,    211,    195,    188,    193,    185,    184,
  371. X    191,    183,    201,    229,    181,    220,    194,    162,
  372. X    163,    208,    186,    202,    200,    218,    198,    179,
  373. X    178,    214,    166,    170,    207,    199,    209,    206,
  374. X    204,    160,    212,    216,    215,    192,    175,    173,
  375. X    243,    172,    161,    190,    203,    189,    164,    230,
  376. X    167,    248,    227,    244,    242,    255,    241,    231,
  377. X    240,    253,    169,    210,    245,    237,    249,    247,
  378. X    239,    168,    252,    251,    254,    238,    223,    221,
  379. X    213,    225,    177,    197,    171,    196,    159,    4,
  380. X    5,    6,    8,    9,    10,    11,    12,    13,
  381. X    14,    15,    16,    17,    19,    20,    21,    22,
  382. X    23,    24,    25,    26,    27,    28,    30,    31,
  383. X    32,    33,    34,    35,    36,    37,    38,    39,
  384. X    41,    42,    43,    44,    45,    46,    47,    48,
  385. X    49,    50,    52,    53,    54,    55,    56,    57,
  386. X    58,    59,    60,    61,    63,    64,    65,    66,
  387. X    67,    68,    69,    70,    71,    72,    74,    75,
  388. X    76,    77,    78,    79,    80,    81,    82,    83,
  389. X    86,    87,    88,    89,    90,    91,    92,    93,
  390. X    94,    95,    97,    98,    99,    100,    101,    102,
  391. X    103,    104,    105,    106,    108,    109,    110,    111,
  392. X    112,    113,    114,    115,    116,    117,    119,    120,
  393. X    121,    122,    123,    124,    125,    126,    127,    128,
  394. X    130,    131,    132,    133,    134,    135,    136,    137,
  395. X    138,    139,    141,    142,    143,    144,    145,    146
  396. X};
  397. X
  398. Xvoid
  399. Xfbmcompile(str, iflag)
  400. XSTR *str;
  401. Xint iflag;
  402. X{
  403. X    register unsigned char *s;
  404. X    register unsigned char *table;
  405. X    register int i;
  406. X    register int len = str->str_cur;
  407. X    int rarest = 0;
  408. X    int frequency = 256;
  409. X
  410. X    str_grow(str,len+258);
  411. X#ifndef lint
  412. X    table = (unsigned char*)(str->str_ptr + len + 1);
  413. X#else
  414. X    table = Null(unsigned char*);
  415. X#endif
  416. X    s = table - 2;
  417. X    for (i = 0; i < 256; i++) {
  418. X    table[i] = len;
  419. X    }
  420. X    i = 0;
  421. X#ifndef lint
  422. X    while (s >= (unsigned char*)(str->str_ptr))
  423. X#endif
  424. X    {
  425. X    if (table[*s] == len) {
  426. X#ifndef pdp11
  427. X        if (iflag)
  428. X        table[*s] = table[fold[*s]] = i;
  429. X#else
  430. X        if (iflag) {
  431. X        int j;
  432. X        j = fold[*s];
  433. X        table[j] = i;
  434. X        table[*s] = i;
  435. X        }
  436. X#endif /* pdp11 */
  437. X        else
  438. X        table[*s] = i;
  439. X    }
  440. X    s--,i++;
  441. X    }
  442. X    str->str_pok |= SP_FBM;        /* deep magic */
  443. X
  444. X#ifndef lint
  445. X    s = (unsigned char*)(str->str_ptr);        /* deeper magic */
  446. X#else
  447. X    s = Null(unsigned char*);
  448. X#endif
  449. X    if (iflag) {
  450. X    register int tmp, foldtmp;
  451. X    str->str_pok |= SP_CASEFOLD;
  452. X    for (i = 0; i < len; i++) {
  453. X        tmp=freq[s[i]];
  454. X        foldtmp=freq[fold[s[i]]];
  455. X        if (tmp < frequency && foldtmp < frequency) {
  456. X        rarest = i;
  457. X        /* choose most frequent among the two */
  458. X        frequency = (tmp > foldtmp) ? tmp : foldtmp;
  459. X        }
  460. X    }
  461. X    }
  462. X    else {
  463. X    for (i = 0; i < len; i++) {
  464. X        if (freq[s[i]] < frequency) {
  465. X        rarest = i;
  466. X        frequency = freq[s[i]];
  467. X        }
  468. X    }
  469. X    }
  470. X    str->str_rare = s[rarest];
  471. X    str->str_state = rarest;
  472. X#ifdef DEBUGGING
  473. X    if (debug & 512)
  474. X    fprintf(stderr,"rarest char %c at %d\n",str->str_rare, str->str_state);
  475. X#endif
  476. X}
  477. X
  478. Xchar *
  479. Xfbminstr(big, bigend, littlestr)
  480. Xunsigned char *big;
  481. Xregister unsigned char *bigend;
  482. XSTR *littlestr;
  483. X{
  484. X    register unsigned char *s;
  485. X    register int tmp;
  486. X    register int littlelen;
  487. X    register unsigned char *little;
  488. X    register unsigned char *table;
  489. X    register unsigned char *olds;
  490. X    register unsigned char *oldlittle;
  491. X
  492. X#ifndef lint
  493. X    if (!(littlestr->str_pok & SP_FBM))
  494. X    return instr((char*)big,littlestr->str_ptr);
  495. X#endif
  496. X
  497. X    littlelen = littlestr->str_cur;
  498. X#ifndef lint
  499. X    if (littlestr->str_pok & SP_TAIL && !multiline) {    /* tail anchored? */
  500. X    little = (unsigned char*)littlestr->str_ptr;
  501. X    if (littlestr->str_pok & SP_CASEFOLD) {    /* oops, fake it */
  502. X        big = bigend - littlelen;        /* just start near end */
  503. X        if (bigend[-1] == '\n' && little[littlelen-1] != '\n')
  504. X        big--;
  505. X    }
  506. X    else {
  507. X        s = bigend - littlelen;
  508. X        if (*s == *little && bcmp(s,little,littlelen)==0)
  509. X        return (char*)s;        /* how sweet it is */
  510. X        else if (bigend[-1] == '\n' && little[littlelen-1] != '\n') {
  511. X            s--;
  512. X        if (*s == *little && bcmp(s,little,littlelen)==0)
  513. X            return (char*)s;
  514. X        }
  515. X        return Nullch;
  516. X    }
  517. X    }
  518. X    table = (unsigned char*)(littlestr->str_ptr + littlelen + 1);
  519. X#else
  520. X    table = Null(unsigned char*);
  521. X#endif
  522. X    s = big + --littlelen;
  523. X    oldlittle = little = table - 2;
  524. X    if (littlestr->str_pok & SP_CASEFOLD) {    /* case insensitive? */
  525. X    while (s < bigend) {
  526. X      top1:
  527. X        if (tmp = table[*s]) {
  528. X        s += tmp;
  529. X        }
  530. X        else {
  531. X        tmp = littlelen;    /* less expensive than calling strncmp() */
  532. X        olds = s;
  533. X        while (tmp--) {
  534. X            if (*--s == *--little || fold[*s] == *little)
  535. X            continue;
  536. X            s = olds + 1;    /* here we pay the price for failure */
  537. X            little = oldlittle;
  538. X            if (s < bigend)    /* fake up continue to outer loop */
  539. X            goto top1;
  540. X            return Nullch;
  541. X        }
  542. X#ifndef lint
  543. X        return (char *)s;
  544. X#endif
  545. X        }
  546. X    }
  547. X    }
  548. X    else {
  549. X    while (s < bigend) {
  550. X      top2:
  551. X        if (tmp = table[*s]) {
  552. X        s += tmp;
  553. X        }
  554. X        else {
  555. X        tmp = littlelen;    /* less expensive than calling strncmp() */
  556. X        olds = s;
  557. X        while (tmp--) {
  558. X            if (*--s == *--little)
  559. X            continue;
  560. X            s = olds + 1;    /* here we pay the price for failure */
  561. X            little = oldlittle;
  562. X            if (s < bigend)    /* fake up continue to outer loop */
  563. X            goto top2;
  564. X            return Nullch;
  565. X        }
  566. X#ifndef lint
  567. X        return (char *)s;
  568. X#endif
  569. X        }
  570. X    }
  571. X    }
  572. X    return Nullch;
  573. X}
  574. X
  575. Xchar *
  576. Xscreaminstr(bigstr, littlestr)
  577. XSTR *bigstr;
  578. XSTR *littlestr;
  579. X{
  580. X    register unsigned char *s, *x;
  581. X    register unsigned char *big;
  582. X    register int pos;
  583. X    register int previous;
  584. X    register int first;
  585. X    register unsigned char *little;
  586. X    register unsigned char *bigend;
  587. X    register unsigned char *littleend;
  588. X
  589. X    if ((pos = screamfirst[littlestr->str_rare]) < 0) 
  590. X    return Nullch;
  591. X#ifndef lint
  592. X    little = (unsigned char *)(littlestr->str_ptr);
  593. X#else
  594. X    little = Null(unsigned char *);
  595. X#endif
  596. X    littleend = little + littlestr->str_cur;
  597. X    first = *little++;
  598. X    previous = littlestr->str_state;
  599. X#ifndef lint
  600. X    big = (unsigned char *)(bigstr->str_ptr);
  601. X#else
  602. X    big = Null(unsigned char*);
  603. X#endif
  604. X    bigend = big + bigstr->str_cur;
  605. X    big -= previous;
  606. X    while (pos < previous) {
  607. X#ifndef lint
  608. X    if (!(pos += screamnext[pos]))
  609. X#endif
  610. X        return Nullch;
  611. X    }
  612. X    if (littlestr->str_pok & SP_CASEFOLD) {    /* case insignificant? */
  613. X    do {
  614. X        if (big[pos] != first && big[pos] != fold[first])
  615. X        continue;
  616. X        for (x=big+pos+1,s=little; s < littleend; /**/ ) {
  617. X        if (x >= bigend)
  618. X            return Nullch;
  619. X        if (*s++ != *x++ && fold[*(s-1)] != *(x-1)) {
  620. X            s--;
  621. X            break;
  622. X        }
  623. X        }
  624. X        if (s == littleend)
  625. X#ifndef lint
  626. X        return (char *)(big+pos);
  627. X#else
  628. X        return Nullch;
  629. X#endif
  630. X    } while (
  631. X#ifndef lint
  632. X        pos += screamnext[pos]    /* does this goof up anywhere? */
  633. X#else
  634. X        pos += screamnext[0]
  635. X#endif
  636. X        );
  637. X    }
  638. X    else {
  639. X    do {
  640. X        if (big[pos] != first)
  641. X        continue;
  642. X        for (x=big+pos+1,s=little; s < littleend; /**/ ) {
  643. X        if (x >= bigend)
  644. X            return Nullch;
  645. X        if (*s++ != *x++) {
  646. X            s--;
  647. X            break;
  648. X        }
  649. X        }
  650. X        if (s == littleend)
  651. X#ifndef lint
  652. X        return (char *)(big+pos);
  653. X#else
  654. X        return Nullch;
  655. X#endif
  656. X    } while (
  657. X#ifndef lint
  658. X        pos += screamnext[pos]
  659. X#else
  660. X        pos += screamnext[0]
  661. X#endif
  662. X        );
  663. X    }
  664. X    return Nullch;
  665. X}
  666. X
  667. X/* copy a string to a safe spot */
  668. X
  669. Xchar *
  670. Xsavestr(str)
  671. Xchar *str;
  672. X{
  673. X    register char *newaddr;
  674. X
  675. X    New(902,newaddr,strlen(str)+1,char);
  676. X    (void)strcpy(newaddr,str);
  677. X    return newaddr;
  678. X}
  679. X
  680. X/* same thing but with a known length */
  681. X
  682. Xchar *
  683. Xnsavestr(str, len)
  684. Xchar *str;
  685. Xregister int len;
  686. X{
  687. X    register char *newaddr;
  688. X
  689. X    New(903,newaddr,len+1,char);
  690. X    (void)bcopy(str,newaddr,len);    /* might not be null terminated */
  691. X    newaddr[len] = '\0';        /* is now */
  692. X    return newaddr;
  693. X}
  694. X
  695. X/* grow a static string to at least a certain length */
  696. X
  697. Xvoid
  698. Xgrowstr(strptr,curlen,newlen)
  699. Xchar **strptr;
  700. Xint *curlen;
  701. Xint newlen;
  702. X{
  703. X    if (newlen > *curlen) {        /* need more room? */
  704. X    if (*curlen)
  705. X        Renew(*strptr,newlen,char);
  706. X    else
  707. X        New(905,*strptr,newlen,char);
  708. X    *curlen = newlen;
  709. X    }
  710. X}
  711. X
  712. Xextern int errno;
  713. X
  714. X#ifndef VARARGS
  715. X/*VARARGS1*/
  716. Xmess(pat,a1,a2,a3,a4)
  717. Xchar *pat;
  718. Xlong a1, a2, a3, a4;
  719. X{
  720. X    char *s;
  721. X
  722. X    s = buf;
  723. X    (void)sprintf(s,pat,a1,a2,a3,a4);
  724. X    s += strlen(s);
  725. X    if (s[-1] != '\n') {
  726. X    if (line) {
  727. X        (void)sprintf(s," at %s line %ld",
  728. X          in_eval?filename:origfilename, (long)line);
  729. X        s += strlen(s);
  730. X    }
  731. X    if (last_in_stab &&
  732. X        stab_io(last_in_stab) &&
  733. X        stab_io(last_in_stab)->lines ) {
  734. X        (void)sprintf(s,", <%s> line %ld",
  735. X          last_in_stab == argvstab ? "" : stab_name(last_in_stab),
  736. X          (long)stab_io(last_in_stab)->lines);
  737. X        s += strlen(s);
  738. X    }
  739. X    (void)strcpy(s,".\n");
  740. X    }
  741. X}
  742. X
  743. X/*VARARGS1*/
  744. Xfatal(pat,a1,a2,a3,a4)
  745. Xchar *pat;
  746. Xlong a1, a2, a3, a4;
  747. X{
  748. X    extern FILE *e_fp;
  749. X    extern char *e_tmpname;
  750. X
  751. X    mess(pat,a1,a2,a3,a4);
  752. X    if (in_eval) {
  753. X    str_set(stab_val(stabent("@",TRUE)),buf);
  754. X    longjmp(eval_env,1);
  755. X    }
  756. X    fputs(buf,stderr);
  757. X    (void)fflush(stderr);
  758. X    if (e_fp)
  759. X    (void)UNLINK(e_tmpname);
  760. X    statusvalue >>= 8;
  761. X    exit(errno?errno:(statusvalue?statusvalue:255));
  762. X}
  763. X
  764. X/*VARARGS1*/
  765. Xwarn(pat,a1,a2,a3,a4)
  766. Xchar *pat;
  767. Xlong a1, a2, a3, a4;
  768. X{
  769. X    mess(pat,a1,a2,a3,a4);
  770. X    fputs(buf,stderr);
  771. X#ifdef LEAKTEST
  772. X#ifdef DEBUGGING
  773. X    if (debug & 4096)
  774. X    xstat();
  775. X#endif
  776. X#endif
  777. X    (void)fflush(stderr);
  778. X}
  779. X#else
  780. X/*VARARGS0*/
  781. Xmess(args)
  782. Xva_list args;
  783. X{
  784. X    char *pat;
  785. X    char *s;
  786. X#ifdef CHARVSPRINTF
  787. X    char *vsprintf();
  788. X#else
  789. X    int vsprintf();
  790. X#endif
  791. X
  792. X    s = buf;
  793. X#ifdef lint
  794. X    pat = Nullch;
  795. X#else
  796. X    pat = va_arg(args, char *);
  797. X#endif
  798. X    (void) vsprintf(s,pat,args);
  799. X
  800. X    s += strlen(s);
  801. X    if (s[-1] != '\n') {
  802. X    if (line) {
  803. X        (void)sprintf(s," at %s line %ld",
  804. X          in_eval?filename:origfilename, (long)line);
  805. X        s += strlen(s);
  806. X    }
  807. X    if (last_in_stab &&
  808. X        stab_io(last_in_stab) &&
  809. X        stab_io(last_in_stab)->lines ) {
  810. X        (void)sprintf(s,", <%s> line %ld",
  811. X          last_in_stab == argvstab ? "" : last_in_stab->str_magic->str_ptr,
  812. X          (long)stab_io(last_in_stab)->lines);
  813. X        s += strlen(s);
  814. X    }
  815. X    (void)strcpy(s,".\n");
  816. X    }
  817. X}
  818. X
  819. X/*VARARGS0*/
  820. Xfatal(va_alist)
  821. Xva_dcl
  822. X{
  823. X    va_list args;
  824. X    extern FILE *e_fp;
  825. X    extern char *e_tmpname;
  826. X
  827. X#ifndef lint
  828. X    va_start(args);
  829. X#else
  830. X    args = 0;
  831. X#endif
  832. X    mess(args);
  833. X    va_end(args);
  834. X    if (in_eval) {
  835. X    str_set(stab_val(stabent("@",TRUE)),buf);
  836. X    longjmp(eval_env,1);
  837. X    }
  838. X    fputs(buf,stderr);
  839. X    (void)fflush(stderr);
  840. X    if (e_fp)
  841. X    (void)UNLINK(e_tmpname);
  842. X    statusvalue >>= 8;
  843. X    exit((int)(errno?errno:(statusvalue?statusvalue:255)));
  844. X}
  845. X
  846. X/*VARARGS0*/
  847. Xwarn(va_alist)
  848. Xva_dcl
  849. X{
  850. X    va_list args;
  851. X
  852. X#ifndef lint
  853. X    va_start(args);
  854. X#else
  855. X    args = 0;
  856. X#endif
  857. X    mess(args);
  858. X    va_end(args);
  859. X
  860. X    fputs(buf,stderr);
  861. X#ifdef LEAKTEST
  862. X#ifdef DEBUGGING
  863. X    if (debug & 4096)
  864. X    xstat();
  865. X#endif
  866. X#endif
  867. X    (void)fflush(stderr);
  868. X}
  869. X#endif
  870. X
  871. Xstatic bool firstsetenv = TRUE;
  872. Xextern char **environ;
  873. X
  874. Xvoid
  875. Xsetenv(nam,val)
  876. Xchar *nam, *val;
  877. X{
  878. X    register int i=envix(nam);        /* where does it go? */
  879. X
  880. X    if (!val) {
  881. X    while (environ[i]) {
  882. X        environ[i] = environ[i+1];
  883. X        i++;
  884. X    }
  885. X    return;
  886. X    }
  887. X    if (!environ[i]) {            /* does not exist yet */
  888. X    if (firstsetenv) {        /* need we copy environment? */
  889. X        int j;
  890. X        char **tmpenv;
  891. X
  892. X        New(901,tmpenv, i+2, char*);
  893. X        firstsetenv = FALSE;
  894. X        for (j=0; j<i; j++)        /* copy environment */
  895. X        tmpenv[j] = environ[j];
  896. X        environ = tmpenv;        /* tell exec where it is now */
  897. X    }
  898. X    else
  899. X        Renew(environ, i+2, char*);    /* just expand it a bit */
  900. X    environ[i+1] = Nullch;    /* make sure it's null terminated */
  901. X    }
  902. X    New(904, environ[i], strlen(nam) + strlen(val) + 2, char);
  903. X                    /* this may or may not be in */
  904. X                    /* the old environ structure */
  905. X    (void)sprintf(environ[i],"%s=%s",nam,val);/* all that work just for this */
  906. X}
  907. X
  908. Xint
  909. Xenvix(nam)
  910. Xchar *nam;
  911. X{
  912. X    register int i, len = strlen(nam);
  913. X
  914. X    for (i = 0; environ[i]; i++) {
  915. X    if (strnEQ(environ[i],nam,len) && environ[i][len] == '=')
  916. X        break;            /* strnEQ must come first to avoid */
  917. X    }                    /* potential SEGV's */
  918. X    return i;
  919. X}
  920. X
  921. X#ifdef EUNICE
  922. Xunlnk(f)    /* unlink all versions of a file */
  923. Xchar *f;
  924. X{
  925. X    int i;
  926. X
  927. X    for (i = 0; unlink(f) >= 0; i++) ;
  928. X    return i ? 0 : -1;
  929. X}
  930. X#endif
  931. X
  932. X#ifndef BCOPY
  933. X#ifndef MEMCPY
  934. Xchar *
  935. Xbcopy(from,to,len)
  936. Xregister char *from;
  937. Xregister char *to;
  938. Xregister int len;
  939. X{
  940. X    char *retval = to;
  941. X
  942. X    while (len--)
  943. X    *to++ = *from++;
  944. X    return retval;
  945. X}
  946. X
  947. Xchar *
  948. Xbzero(loc,len)
  949. Xregister char *loc;
  950. Xregister int len;
  951. X{
  952. X    char *retval = loc;
  953. X
  954. X    while (len--)
  955. X    *loc++ = 0;
  956. X    return retval;
  957. X}
  958. X#endif
  959. X#endif
  960. X
  961. X#ifdef VARARGS
  962. X#ifndef VPRINTF
  963. X
  964. X#ifdef CHARVSPRINTF
  965. Xchar *
  966. X#else
  967. Xint
  968. X#endif
  969. Xvsprintf(dest, pat, args)
  970. Xchar *dest, *pat, *args;
  971. X{
  972. X    FILE fakebuf;
  973. X
  974. X    fakebuf._ptr = dest;
  975. X    fakebuf._cnt = 32767;
  976. X    fakebuf._flag = _IOWRT|_IOSTRG;
  977. X    _doprnt(pat, args, &fakebuf);    /* what a kludge */
  978. X    (void)putc('\0', &fakebuf);
  979. X#ifdef CHARVSPRINTF
  980. X    return(dest);
  981. X#else
  982. X    return 0;        /* perl doesn't use return value */
  983. X#endif
  984. X}
  985. X
  986. X#ifdef DEBUGGING
  987. Xint
  988. Xvfprintf(fd, pat, args)
  989. XFILE *fd;
  990. Xchar *pat, *args;
  991. X{
  992. X    _doprnt(pat, args, fd);
  993. X    return 0;        /* wrong, but perl doesn't use the return value */
  994. X}
  995. X#endif
  996. X#endif /* VPRINTF */
  997. X#endif /* VARARGS */
  998. X
  999. X#ifdef MYSWAP
  1000. X#if BYTEORDER != 04321
  1001. Xshort
  1002. Xmy_swap(s)
  1003. Xshort s;
  1004. X{
  1005. X#if (BYTEORDER & 1) == 0
  1006. X    short result;
  1007. X
  1008. X    result = ((s & 255) << 8) + ((s >> 8) & 255);
  1009. X    return result;
  1010. X#else
  1011. X    return s;
  1012. X#endif
  1013. X}
  1014. X
  1015. Xlong
  1016. Xhtonl(l)
  1017. Xregister long l;
  1018. X{
  1019. X    union {
  1020. X    long result;
  1021. X    char c[4];
  1022. X    } u;
  1023. X
  1024. X#if BYTEORDER == 01234
  1025. X    u.c[0] = (l >> 24) & 255;
  1026. X    u.c[1] = (l >> 16) & 255;
  1027. X    u.c[2] = (l >> 8) & 255;
  1028. X    u.c[3] = l & 255;
  1029. X    return u.result;
  1030. X#else
  1031. X#if ((BYTEORDER - 01111) & 0444) || !(BYTEORDER & 7)
  1032. X    fatal("Unknown BYTEORDER\n");
  1033. X#else
  1034. X    register int o;
  1035. X    register int s;
  1036. X
  1037. X    for (o = BYTEORDER - 01111, s = 0; s < 32; o >>= 3, s += 8) {
  1038. X    u.c[o & 7] = (l >> s) & 255;
  1039. X    }
  1040. X    return u.result;
  1041. X#endif
  1042. X#endif
  1043. X}
  1044. X
  1045. Xlong
  1046. Xntohl(l)
  1047. Xregister long l;
  1048. X{
  1049. X    union {
  1050. X    long l;
  1051. X    char c[4];
  1052. X    } u;
  1053. X
  1054. X#if BYTEORDER == 01234
  1055. X    u.c[0] = (l >> 24) & 255;
  1056. X    u.c[1] = (l >> 16) & 255;
  1057. X    u.c[2] = (l >> 8) & 255;
  1058. X    u.c[3] = l & 255;
  1059. X    return u.l;
  1060. X#else
  1061. X#if ((BYTEORDER - 01111) & 0444) || !(BYTEORDER & 7)
  1062. X    fatal("Unknown BYTEORDER\n");
  1063. X#else
  1064. X    register int o;
  1065. X    register int s;
  1066. X
  1067. X    u.l = l;
  1068. X    l = 0;
  1069. X    for (o = BYTEORDER - 01111, s = 0; s < 32; o >>= 3, s += 8) {
  1070. X    l |= (u.c[o & 7] & 255) << s;
  1071. X    }
  1072. X    return l;
  1073. X#endif
  1074. X#endif
  1075. X}
  1076. X
  1077. X#endif /* BYTEORDER != 04321 */
  1078. X#endif /* HTONS */
  1079. X
  1080. XFILE *
  1081. Xmypopen(cmd,mode)
  1082. Xchar    *cmd;
  1083. Xchar    *mode;
  1084. X{
  1085. X    int p[2];
  1086. X    register int this, that;
  1087. X    register int pid;
  1088. X    STR *str;
  1089. X    int doexec = strNE(cmd,"-");
  1090. X
  1091. X    if (pipe(p) < 0)
  1092. X    return Nullfp;
  1093. X    this = (*mode == 'w');
  1094. X    that = !this;
  1095. X    while ((pid = (doexec?vfork():fork())) < 0) {
  1096. X    if (errno != EAGAIN) {
  1097. X        close(p[this]);
  1098. X        if (!doexec)
  1099. X        fatal("Can't fork");
  1100. X        return Nullfp;
  1101. X    }
  1102. X    sleep(5);
  1103. X    }
  1104. X    if (pid == 0) {
  1105. X#define THIS that
  1106. X#define THAT this
  1107. X    close(p[THAT]);
  1108. X    if (p[THIS] != (*mode == 'r')) {
  1109. X        dup2(p[THIS], *mode == 'r');
  1110. X        close(p[THIS]);
  1111. X    }
  1112. X    if (doexec) {
  1113. X        do_exec(cmd);    /* may or may not use the shell */
  1114. X        _exit(1);
  1115. X    }
  1116. X    if (tmpstab = stabent("$",allstabs))
  1117. X        str_numset(STAB_STR(tmpstab),(double)getpid());
  1118. X    return Nullfp;
  1119. X#undef THIS
  1120. X#undef THAT
  1121. X    }
  1122. X    close(p[that]);
  1123. X    str = afetch(pidstatary,p[this],TRUE);
  1124. X    str_numset(str,(double)pid);
  1125. X    str->str_cur = 0;
  1126. X    forkprocess = pid;
  1127. X    return fdopen(p[this], mode);
  1128. X}
  1129. X
  1130. X#ifndef DUP2
  1131. Xdup2(oldfd,newfd)
  1132. Xint oldfd;
  1133. Xint newfd;
  1134. X{
  1135. X    close(newfd);
  1136. X    while (dup(oldfd) != newfd) ;    /* good enough for our purposes */
  1137. X}
  1138. X#endif
  1139. X
  1140. Xint
  1141. Xmypclose(ptr)
  1142. XFILE *ptr;
  1143. X{
  1144. X    register int result;
  1145. X#ifdef VOIDSIG
  1146. X    void (*hstat)(), (*istat)(), (*qstat)();
  1147. X#else
  1148. X    int (*hstat)(), (*istat)(), (*qstat)();
  1149. X#endif
  1150. X    int status;
  1151. X    STR *str;
  1152. X    register int pid;
  1153. X
  1154. X    str = afetch(pidstatary,fileno(ptr),TRUE);
  1155. X    fclose(ptr);
  1156. X    pid = (int)str_gnum(str);
  1157. X    if (!pid)
  1158. X    return -1;
  1159. X    hstat = signal(SIGHUP, SIG_IGN);
  1160. X    istat = signal(SIGINT, SIG_IGN);
  1161. X    qstat = signal(SIGQUIT, SIG_IGN);
  1162. X#ifdef WAIT4
  1163. X    if (wait4(pid,&status,0,Null(struct rusage *)) < 0)
  1164. X    status = -1;
  1165. X#else
  1166. X    if (pid < 0)        /* already exited? */
  1167. X    status = str->str_cur;
  1168. X    else {
  1169. X    while ((result = wait(&status)) != pid && result >= 0)
  1170. X        pidgone(result,status);
  1171. X    if (result < 0)
  1172. X        status = -1;
  1173. X    }
  1174. X#endif
  1175. X    signal(SIGHUP, hstat);
  1176. X    signal(SIGINT, istat);
  1177. X    signal(SIGQUIT, qstat);
  1178. X    str_numset(str,0.0);
  1179. X    return(status);
  1180. X}
  1181. X
  1182. Xpidgone(pid,status)
  1183. Xint pid;
  1184. Xint status;
  1185. X{
  1186. X#ifdef WAIT4
  1187. X    return;
  1188. X#else
  1189. X    register int count;
  1190. X    register STR *str;
  1191. X
  1192. X    for (count = pidstatary->ary_fill; count >= 0; --count) {
  1193. X    if ((str = afetch(pidstatary,count,FALSE)) &&
  1194. X      ((int)str->str_u.str_nval) == pid) {
  1195. X        str_numset(str, -str->str_u.str_nval);
  1196. X        str->str_cur = status;
  1197. X        return;
  1198. X    }
  1199. X    }
  1200. X#endif
  1201. X}
  1202. X
  1203. X#ifndef MEMCMP
  1204. Xmemcmp(s1,s2,len)
  1205. Xregister unsigned char *s1;
  1206. Xregister unsigned char *s2;
  1207. Xregister int len;
  1208. X{
  1209. X    register int tmp;
  1210. X
  1211. X    while (len--) {
  1212. X    if (tmp = *s1++ - *s2++)
  1213. X        return tmp;
  1214. X    }
  1215. X    return 0;
  1216. X}
  1217. X#endif /* MEMCMP */
  1218. !STUFFY!FUNK!
  1219. echo Extracting perly.c
  1220. sed >perly.c <<'!STUFFY!FUNK!' -e 's/X//'
  1221. Xchar rcsid[] = "$Header: perly.c,v 3.0 89/10/18 15:22:21 lwall Locked $\nPatch level: ###\n";
  1222. X/*
  1223. X *    Copyright (c) 1989, Larry Wall
  1224. X *
  1225. X *    You may distribute under the terms of the GNU General Public License
  1226. X *    as specified in the README file that comes with the perl 3.0 kit.
  1227. X *
  1228. X * $Log:    perly.c,v $
  1229. X * Revision 3.0  89/10/18  15:22:21  lwall
  1230. X * 3.0 baseline
  1231. X * 
  1232. X */
  1233. X
  1234. X#include "EXTERN.h"
  1235. X#include "perl.h"
  1236. X#include "perly.h"
  1237. X#include "patchlevel.h"
  1238. X
  1239. X#ifdef IAMSUID
  1240. X#ifndef DOSUID
  1241. X#define DOSUID
  1242. X#endif
  1243. X#endif
  1244. X
  1245. X#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
  1246. X#ifdef DOSUID
  1247. X#undef DOSUID
  1248. X#endif
  1249. X#endif
  1250. X
  1251. Xmain(argc,argv,env)
  1252. Xregister int argc;
  1253. Xregister char **argv;
  1254. Xregister char **env;
  1255. X{
  1256. X    register STR *str;
  1257. X    register char *s;
  1258. X    char *index(), *strcpy(), *getenv();
  1259. X    bool dosearch = FALSE;
  1260. X    char **origargv = argv;
  1261. X#ifdef DOSUID
  1262. X    char *validarg = "";
  1263. X#endif
  1264. X
  1265. X#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
  1266. X#ifdef IAMSUID
  1267. X#undef IAMSUID
  1268. X    fatal("suidperl is no longer needed since the kernel can now execute\n\
  1269. Xsetuid perl scripts securely.\n");
  1270. X#endif
  1271. X#endif
  1272. X
  1273. X    uid = (int)getuid();
  1274. X    euid = (int)geteuid();
  1275. X    gid = (int)getgid();
  1276. X    egid = (int)getegid();
  1277. X    if (do_undump) {
  1278. X    do_undump = 0;
  1279. X    loop_ptr = 0;        /* start label stack again */
  1280. X    goto just_doit;
  1281. X    }
  1282. X    (void)sprintf(index(rcsid,'#'), "%d\n", PATCHLEVEL);
  1283. X    linestr = Str_new(65,80);
  1284. X    str_nset(linestr,"",0);
  1285. X    str = str_make("",0);        /* first used for -I flags */
  1286. X    curstash = defstash = hnew(0);
  1287. X    curstname = str_make("main",4);
  1288. X    stab_xhash(stabent("_main",TRUE)) = defstash;
  1289. X    incstab = aadd(stabent("INC",TRUE));
  1290. X    incstab->str_pok |= SP_MULTI;
  1291. X    for (argc--,argv++; argc; argc--,argv++) {
  1292. X    if (argv[0][0] != '-' || !argv[0][1])
  1293. X        break;
  1294. X#ifdef DOSUID
  1295. X    if (*validarg)
  1296. X    validarg = " PHOOEY ";
  1297. X    else
  1298. X    validarg = argv[0];
  1299. X#endif
  1300. X    s = argv[0]+1;
  1301. X      reswitch:
  1302. X    switch (*s) {
  1303. X    case 'a':
  1304. X        minus_a = TRUE;
  1305. X        s++;
  1306. X        goto reswitch;
  1307. X    case 'd':
  1308. X#ifdef TAINT
  1309. X        if (euid != uid || egid != gid)
  1310. X        fatal("No -d allowed in setuid scripts");
  1311. X#endif
  1312. X        perldb = TRUE;
  1313. X        s++;
  1314. X        goto reswitch;
  1315. X#ifdef DEBUGGING
  1316. X    case 'D':
  1317. X#ifdef TAINT
  1318. X        if (euid != uid || egid != gid)
  1319. X        fatal("No -D allowed in setuid scripts");
  1320. X#endif
  1321. X        debug = atoi(s+1);
  1322. X#ifdef YYDEBUG
  1323. X        yydebug = (debug & 1);
  1324. X#endif
  1325. X        break;
  1326. X#endif
  1327. X    case 'e':
  1328. X#ifdef TAINT
  1329. X        if (euid != uid || egid != gid)
  1330. X        fatal("No -e allowed in setuid scripts");
  1331. X#endif
  1332. X        if (!e_fp) {
  1333. X            e_tmpname = savestr(TMPPATH);
  1334. X        (void)mktemp(e_tmpname);
  1335. X        e_fp = fopen(e_tmpname,"w");
  1336. X        }
  1337. X        if (argv[1])
  1338. X        fputs(argv[1],e_fp);
  1339. X        (void)putc('\n', e_fp);
  1340. X        argc--,argv++;
  1341. X        break;
  1342. X    case 'i':
  1343. X        inplace = savestr(s+1);
  1344. X        argvoutstab = stabent("ARGVOUT",TRUE);
  1345. X        break;
  1346. X    case 'I':
  1347. X#ifdef TAINT
  1348. X        if (euid != uid || egid != gid)
  1349. X        fatal("No -I allowed in setuid scripts");
  1350. X#endif
  1351. X        str_cat(str,"-");
  1352. X        str_cat(str,s);
  1353. X        str_cat(str," ");
  1354. X        if (*++s) {
  1355. X        (void)apush(stab_array(incstab),str_make(s,0));
  1356. X        }
  1357. X        else {
  1358. X        (void)apush(stab_array(incstab),str_make(argv[1],0));
  1359. X        str_cat(str,argv[1]);
  1360. X        argc--,argv++;
  1361. X        str_cat(str," ");
  1362. X        }
  1363. X        break;
  1364. X    case 'n':
  1365. X        minus_n = TRUE;
  1366. X        s++;
  1367. X        goto reswitch;
  1368. X    case 'p':
  1369. X        minus_p = TRUE;
  1370. X        s++;
  1371. X        goto reswitch;
  1372. X    case 'P':
  1373. X#ifdef TAINT
  1374. X        if (euid != uid || egid != gid)
  1375. X        fatal("No -P allowed in setuid scripts");
  1376. X#endif
  1377. X        preprocess = TRUE;
  1378. X        s++;
  1379. X        goto reswitch;
  1380. X    case 's':
  1381. X#ifdef TAINT
  1382. X        if (euid != uid || egid != gid)
  1383. X        fatal("No -s allowed in setuid scripts");
  1384. X#endif
  1385. X        doswitches = TRUE;
  1386. X        s++;
  1387. X        goto reswitch;
  1388. X    case 'S':
  1389. X        dosearch = TRUE;
  1390. X        s++;
  1391. X        goto reswitch;
  1392. X    case 'u':
  1393. X        do_undump = TRUE;
  1394. X        s++;
  1395. X        goto reswitch;
  1396. X    case 'U':
  1397. X        unsafe = TRUE;
  1398. X        s++;
  1399. X        goto reswitch;
  1400. X    case 'v':
  1401. X        fputs(rcsid,stdout);
  1402. X        fputs("\nCopyright (c) 1989, Larry Wall\n\n\
  1403. XPerl may be copied only under the terms of the GNU General Public License,\n\
  1404. Xa copy of which can be found with the Perl 3.0 distribution kit.\n",stdout);
  1405. X        exit(0);
  1406. X    case 'w':
  1407. X        dowarn = TRUE;
  1408. X        s++;
  1409. X        goto reswitch;
  1410. X    case '-':
  1411. X        argc--,argv++;
  1412. X        goto switch_end;
  1413. X    case 0:
  1414. X        break;
  1415. X    default:
  1416. X        fatal("Unrecognized switch: -%s",s);
  1417. X    }
  1418. X    }
  1419. X  switch_end:
  1420. X    if (e_fp) {
  1421. X    (void)fclose(e_fp);
  1422. X    argc++,argv--;
  1423. X    argv[0] = e_tmpname;
  1424. X    }
  1425. X#ifndef PRIVLIB
  1426. X#define PRIVLIB "/usr/local/lib/perl"
  1427. X#endif
  1428. X    (void)apush(stab_array(incstab),str_make(PRIVLIB,0));
  1429. X
  1430. X    str_set(&str_no,No);
  1431. X    str_set(&str_yes,Yes);
  1432. X
  1433. X    /* open script */
  1434. X
  1435. X    if (argv[0] == Nullch)
  1436. X    argv[0] = "-";
  1437. X    if (dosearch && !index(argv[0], '/') && (s = getenv("PATH"))) {
  1438. X    char *xfound = Nullch, *xfailed = Nullch;
  1439. X    int len;
  1440. X
  1441. X    bufend = s + strlen(s);
  1442. X    while (*s) {
  1443. X        s = cpytill(tokenbuf,s,bufend,':',&len);
  1444. X        if (*s)
  1445. X        s++;
  1446. X        if (len)
  1447. X        (void)strcat(tokenbuf+len,"/");
  1448. X        (void)strcat(tokenbuf+len,argv[0]);
  1449. X#ifdef DEBUGGING
  1450. X        if (debug & 1)
  1451. X        fprintf(stderr,"Looking for %s\n",tokenbuf);
  1452. X#endif
  1453. X        if (stat(tokenbuf,&statbuf) < 0)        /* not there? */
  1454. X        continue;
  1455. X        if ((statbuf.st_mode & S_IFMT) == S_IFREG
  1456. X         && cando(S_IREAD,TRUE,&statbuf) && cando(S_IEXEC,TRUE,&statbuf)) {
  1457. X        xfound = tokenbuf;              /* bingo! */
  1458. X        break;
  1459. X        }
  1460. X        if (!xfailed)
  1461. X        xfailed = savestr(tokenbuf);
  1462. X    }
  1463. X    if (!xfound)
  1464. X        fatal("Can't execute %s", xfailed ? xfailed : argv[0] );
  1465. X    if (xfailed)
  1466. X        Safefree(xfailed);
  1467. X    argv[0] = savestr(xfound);
  1468. X    }
  1469. X
  1470. X    pidstatary = anew(Nullstab);    /* for remembering popen pids, status */
  1471. X
  1472. X    filename = savestr(argv[0]);
  1473. X    origfilename = savestr(filename);
  1474. X    if (strEQ(filename,"-"))
  1475. X    argv[0] = "";
  1476. X    if (preprocess) {
  1477. X    str_cat(str,"-I");
  1478. X    str_cat(str,PRIVLIB);
  1479. X    (void)sprintf(buf, "\
  1480. X/bin/sed -e '/^[^#]/b' \
  1481. X -e '/^#[     ]*include[     ]/b' \
  1482. X -e '/^#[     ]*define[     ]/b' \
  1483. X -e '/^#[     ]*if[     ]/b' \
  1484. X -e '/^#[     ]*ifdef[     ]/b' \
  1485. X -e '/^#[     ]*ifndef[     ]/b' \
  1486. X -e '/^#[     ]*else/b' \
  1487. X -e '/^#[     ]*endif/b' \
  1488. X -e 's/^#.*//' \
  1489. X %s | %s -C %s %s",
  1490. X      argv[0], CPPSTDIN, str_get(str), CPPMINUS);
  1491. X#ifdef IAMSUID                /* actually, this is caught earlier */
  1492. X    if (euid != uid && !euid)    /* if running suidperl */
  1493. X#ifdef SETEUID
  1494. X        (void)seteuid(uid);        /* musn't stay setuid root */
  1495. X#else
  1496. X#ifdef SETREUID
  1497. X        (void)setreuid(-1, uid);
  1498. X#else
  1499. X        setuid(uid);
  1500. X#endif
  1501. X#endif
  1502. X#endif /* IAMSUID */
  1503. X    rsfp = mypopen(buf,"r");
  1504. X    }
  1505. X    else if (!*argv[0])
  1506. X    rsfp = stdin;
  1507. X    else
  1508. X    rsfp = fopen(argv[0],"r");
  1509. X    if (rsfp == Nullfp) {
  1510. X    extern char *sys_errlist[];
  1511. X    extern int errno;
  1512. X
  1513. X#ifdef DOSUID
  1514. X#ifndef IAMSUID        /* in case script is not readable before setuid */
  1515. X    if (euid && stat(filename,&statbuf) >= 0 &&
  1516. X      statbuf.st_mode & (S_ISUID|S_ISGID)) {
  1517. X        (void)sprintf(buf, "%s/%s", BIN, "suidperl");
  1518. X        execv(buf, origargv);    /* try again */
  1519. X        fatal("Can't do setuid\n");
  1520. X    }
  1521. X#endif
  1522. X#endif
  1523. X    fatal("Can't open perl script \"%s\": %s\n",
  1524. X      filename, sys_errlist[errno]);
  1525. X    }
  1526. X    str_free(str);        /* free -I directories */
  1527. X
  1528. X    /* do we need to emulate setuid on scripts? */
  1529. X
  1530. X    /* This code is for those BSD systems that have setuid #! scripts disabled
  1531. X     * in the kernel because of a security problem.  Merely defining DOSUID
  1532. X     * in perl will not fix that problem, but if you have disabled setuid
  1533. X     * scripts in the kernel, this will attempt to emulate setuid and setgid
  1534. X     * on scripts that have those now-otherwise-useless bits set.  The setuid
  1535. X     * root version must be called suidperl.  If regular perl discovers that
  1536. X     * it has opened a setuid script, it calls suidperl with the same argv
  1537. X     * that it had.  If suidperl finds that the script it has just opened
  1538. X     * is NOT setuid root, it sets the effective uid back to the uid.  We
  1539. X     * don't just make perl setuid root because that loses the effective
  1540. X     * uid we had before invoking perl, if it was different from the uid.
  1541. X     *
  1542. X     * DOSUID must be defined in both perl and suidperl, and IAMSUID must
  1543. X     * be defined in suidperl only.  suidperl must be setuid root.  The
  1544. X     * Configure script will set this up for you if you want it.
  1545. X     *
  1546. X     * There is also the possibility of have a script which is running
  1547. X     * set-id due to a C wrapper.  We want to do the TAINT checks
  1548. X     * on these set-id scripts, but don't want to have the overhead of
  1549. X     * them in normal perl, and can't use suidperl because it will lose
  1550. X     * the effective uid info, so we have an additional non-setuid root
  1551. X     * version called taintperl that just does the TAINT checks.
  1552. X     */
  1553. X
  1554. X#ifdef DOSUID
  1555. X    if (fstat(fileno(rsfp),&statbuf) < 0)    /* normal stat is insecure */
  1556. X    fatal("Can't stat script \"%s\"",filename);
  1557. X    if (statbuf.st_mode & (S_ISUID|S_ISGID)) {
  1558. X    int len;
  1559. X
  1560. X#ifdef IAMSUID
  1561. X#ifndef SETREUID
  1562. X    /* On this access check to make sure the directories are readable,
  1563. X     * there is actually a small window that the user could use to make
  1564. X     * filename point to an accessible directory.  So there is a faint
  1565. X     * chance that someone could execute a setuid script down in a
  1566. X     * non-accessible directory.  I don't know what to do about that.
  1567. X     * But I don't think it's too important.  The manual lies when
  1568. X     * it says access() is useful in setuid programs.
  1569. X     */
  1570. X    if (access(filename,1))        /* as a double check */
  1571. X        fatal("Permission denied");
  1572. X#else
  1573. X    /* If we can swap euid and uid, then we can determine access rights
  1574. X     * with a simple stat of the file, and then compare device and
  1575. X     * inode to make sure we did stat() on the same file we opened.
  1576. X     * Then we just have to make sure he or she can execute it.
  1577. X     */
  1578. X    {
  1579. X        struct stat tmpstatbuf;
  1580. X
  1581. X        if (setreuid(euid,uid) < 0 || getuid() != euid || geteuid() != uid)
  1582. X        fatal("Can't swap uid and euid");    /* really paranoid */
  1583. X        if (stat(filename,&tmpstatbuf) < 0) /* testing full pathname here */
  1584. X        fatal("Permission denied");
  1585. X        if (tmpstatbuf.st_dev != statbuf.st_dev ||
  1586. X        tmpstatbuf.st_ino != statbuf.st_ino) {
  1587. X        (void)fclose(rsfp);
  1588. X        if (rsfp = mypopen("/bin/mail root","w")) {    /* heh, heh */
  1589. X            fprintf(rsfp,
  1590. X"User %d tried to run dev %d ino %d in place of dev %d ino %d!\n\
  1591. X(Filename of set-id script was %s, uid %d gid %d.)\n\nSincerely,\nperl\n",
  1592. X            uid,tmpstatbuf.st_dev, tmpstatbuf.st_ino,
  1593. X            statbuf.st_dev, statbuf.st_ino,
  1594. X            filename, statbuf.st_uid, statbuf.st_gid);
  1595. X            (void)mypclose(rsfp);
  1596. X        }
  1597. X        fatal("Permission denied\n");
  1598. X        }
  1599. X        if (setreuid(uid,euid) < 0 || getuid() != uid || geteuid() != euid)
  1600. X        fatal("Can't reswap uid and euid");
  1601. X        if (!cando(S_IEXEC,FALSE,&statbuf))        /* can real uid exec? */
  1602. X        fatal("Permission denied\n");
  1603. X    }
  1604. X#endif /* SETREUID */
  1605. X#endif /* IAMSUID */
  1606. X
  1607. X    if ((statbuf.st_mode & S_IFMT) != S_IFREG)
  1608. X        fatal("Permission denied");
  1609. X    if ((statbuf.st_mode >> 6) & S_IWRITE)
  1610. X        fatal("Setuid/gid script is writable by world");
  1611. X    doswitches = FALSE;        /* -s is insecure in suid */
  1612. X    line++;
  1613. X    if (fgets(tokenbuf,sizeof tokenbuf, rsfp) == Nullch ||
  1614. X      strnNE(tokenbuf,"#!",2) )    /* required even on Sys V */
  1615. X        fatal("No #! line");
  1616. X    for (s = tokenbuf+2; !isspace(*s); s++) ;
  1617. X    if (strnNE(s-4,"perl",4))    /* sanity check */
  1618. X        fatal("Not a perl script");
  1619. X    while (*s == ' ' || *s == '\t') s++;
  1620. X    /*
  1621. X     * #! arg must be what we saw above.  They can invoke it by
  1622. X     * mentioning suidperl explicitly, but they may not add any strange
  1623. X     * arguments beyond what #! says if they do invoke suidperl that way.
  1624. X     */
  1625. X    len = strlen(validarg);
  1626. X    if (strEQ(validarg," PHOOEY ") ||
  1627. X        strnNE(s,validarg,len) || !isspace(s[len]))
  1628. X        fatal("Args must match #! line");
  1629. X
  1630. X#ifndef IAMSUID
  1631. X    if (euid != uid && (statbuf.st_mode & S_ISUID) &&
  1632. X        euid == statbuf.st_uid)
  1633. X        if (!do_undump)
  1634. X        fatal("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
  1635. XFIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
  1636. X#endif /* IAMSUID */
  1637. X
  1638. X    if (euid) {    /* oops, we're not the setuid root perl */
  1639. X        (void)fclose(rsfp);
  1640. X#ifndef IAMSUID
  1641. X        (void)sprintf(buf, "%s/%s", BIN, "suidperl");
  1642. X        execv(buf, origargv);    /* try again */
  1643. X#endif
  1644. X        fatal("Can't do setuid\n");
  1645. X    }
  1646. X
  1647. X    if (statbuf.st_mode & S_ISGID && statbuf.st_gid != getegid())
  1648. X#ifdef SETEGID
  1649. X        (void)setegid(statbuf.st_gid);
  1650. X#else
  1651. X#ifdef SETREGID
  1652. X        (void)setregid((GIDTYPE)-1,statbuf.st_gid);
  1653. X#else
  1654. X        setgid(statbuf.st_gid);
  1655. X#endif
  1656. X#endif
  1657. X    if (statbuf.st_mode & S_ISUID) {
  1658. X        if (statbuf.st_uid != euid)
  1659. X#ifdef SETEUID
  1660. X        (void)seteuid(statbuf.st_uid);    /* all that for this */
  1661. X#else
  1662. X#ifdef SETREUID
  1663. X        (void)setreuid((UIDTYPE)-1,statbuf.st_uid);
  1664. X#else
  1665. X        setuid(statbuf.st_uid);
  1666. X#endif
  1667. X#endif
  1668. X    }
  1669. X    else if (uid)            /* oops, mustn't run as root */
  1670. X#ifdef SETEUID
  1671. X        (void)seteuid((UIDTYPE)uid);
  1672. X#else
  1673. X#ifdef SETREUID
  1674. X        (void)setreuid((UIDTYPE)-1,(UIDTYPE)uid);
  1675. X#else
  1676. X        setuid((UIDTYPE)uid);
  1677. X#endif
  1678. X#endif
  1679. X    euid = (int)geteuid();
  1680. X    if (!cando(S_IEXEC,TRUE,&statbuf))
  1681. X        fatal("Permission denied\n");    /* they can't do this */
  1682. X    }
  1683. X#ifdef IAMSUID
  1684. X    else if (preprocess)
  1685. X    fatal("-P not allowed for setuid/setgid script\n");
  1686. X    else
  1687. X    fatal("Script is not setuid/setgid in suidperl\n");
  1688. X#else
  1689. X#ifndef TAINT        /* we aren't taintperl or suidperl */
  1690. X    /* script has a wrapper--can't run suidperl or we lose euid */
  1691. X    else if (euid != uid || egid != gid) {
  1692. X    (void)fclose(rsfp);
  1693. X    (void)sprintf(buf, "%s/%s", BIN, "taintperl");
  1694. X    execv(buf, origargv);    /* try again */
  1695. X    fatal("Can't run setuid script with taint checks");
  1696. X    }
  1697. X#endif /* TAINT */
  1698. X#endif /* IAMSUID */
  1699. X#else /* !DOSUID */
  1700. X#ifndef TAINT        /* we aren't taintperl or suidperl */
  1701. X    if (euid != uid || egid != gid) {    /* (suidperl doesn't exist, in fact) */
  1702. X#ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
  1703. X    fstat(fileno(rsfp),&statbuf);    /* may be either wrapped or real suid */
  1704. X    if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
  1705. X        ||
  1706. X        (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
  1707. X       )
  1708. X        if (!do_undump)
  1709. X        fatal("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
  1710. XFIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
  1711. X#endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
  1712. X    /* not set-id, must be wrapped */
  1713. X    (void)fclose(rsfp);
  1714. X    (void)sprintf(buf, "%s/%s", BIN, "taintperl");
  1715. X    execv(buf, origargv);    /* try again */
  1716. X    fatal("Can't run setuid script with taint checks");
  1717. X    }
  1718. X#endif /* TAINT */
  1719. X#endif /* DOSUID */
  1720. X
  1721. X    defstab = stabent("_",TRUE);
  1722. X
  1723. X    if (perldb) {
  1724. X    debstash = hnew(0);
  1725. X    stab_xhash(stabent("_DB",TRUE)) = debstash;
  1726. X    curstash = debstash;
  1727. X    lineary = stab_xarray(aadd((tmpstab = stabent("line",TRUE))));
  1728. X    tmpstab->str_pok |= SP_MULTI;
  1729. X    subname = str_make("main",4);
  1730. X    DBstab = stabent("DB",TRUE);
  1731. X    DBstab->str_pok |= SP_MULTI;
  1732. X    DBsub = hadd(tmpstab = stabent("sub",TRUE));
  1733. X    tmpstab->str_pok |= SP_MULTI;
  1734. X    DBsingle = stab_val((tmpstab = stabent("single",TRUE)));
  1735. X    tmpstab->str_pok |= SP_MULTI;
  1736. X    curstash = defstash;
  1737. X    }
  1738. X
  1739. X    /* init tokener */
  1740. X
  1741. X    bufend = bufptr = str_get(linestr);
  1742. X
  1743. X    savestack = anew(Nullstab);        /* for saving non-local values */
  1744. X    stack = anew(Nullstab);        /* for saving non-local values */
  1745. X    stack->ary_flags = 0;        /* not a real array */
  1746. X
  1747. X    /* now parse the script */
  1748. X
  1749. X    error_count = 0;
  1750. X    if (yyparse() || error_count)
  1751. X    fatal("Execution aborted due to compilation errors.\n");
  1752. X
  1753. X    New(50,loop_stack,128,struct loop);
  1754. X    New(51,debname,128,char);
  1755. X    New(52,debdelim,128,char);
  1756. X    curstash = defstash;
  1757. X
  1758. X    preprocess = FALSE;
  1759. X    if (e_fp) {
  1760. X    e_fp = Nullfp;
  1761. X    (void)UNLINK(e_tmpname);
  1762. X    }
  1763. X
  1764. X    /* initialize everything that won't change if we undump */
  1765. X
  1766. X    if (sigstab = stabent("SIG",allstabs)) {
  1767. X    sigstab->str_pok |= SP_MULTI;
  1768. X    (void)hadd(sigstab);
  1769. X    }
  1770. X
  1771. X    magicalize("!#?^~=-%0123456789.+&*()<>,\\/[|`':");
  1772. X
  1773. X    amperstab = stabent("&",allstabs);
  1774. X    leftstab = stabent("`",allstabs);
  1775. X    rightstab = stabent("'",allstabs);
  1776. X    sawampersand = (amperstab || leftstab || rightstab);
  1777. X    if (tmpstab = stabent(":",allstabs))
  1778. X    str_set(STAB_STR(tmpstab),chopset);
  1779. X
  1780. X    /* these aren't necessarily magical */
  1781. X    if (tmpstab = stabent(";",allstabs))
  1782. X    str_set(STAB_STR(tmpstab),"\034");
  1783. X#ifdef TAINT
  1784. X    tainted = 1;
  1785. X#endif
  1786. X    if (tmpstab = stabent("0",allstabs))
  1787. X    str_set(STAB_STR(tmpstab),origfilename);
  1788. X#ifdef TAINT
  1789. X    tainted = 0;
  1790. X#endif
  1791. X    if (tmpstab = stabent("]",allstabs))
  1792. X    str_set(STAB_STR(tmpstab),rcsid);
  1793. X    str_nset(stab_val(stabent("\"", TRUE)), " ", 1);
  1794. X
  1795. X    stdinstab = stabent("STDIN",TRUE);
  1796. X    stdinstab->str_pok |= SP_MULTI;
  1797. X    stab_io(stdinstab) = stio_new();
  1798. X    stab_io(stdinstab)->ifp = stdin;
  1799. X    tmpstab = stabent("stdin",TRUE);
  1800. X    stab_io(tmpstab) = stab_io(stdinstab);
  1801. X    tmpstab->str_pok |= SP_MULTI;
  1802. X
  1803. X    tmpstab = stabent("STDOUT",TRUE);
  1804. X    tmpstab->str_pok |= SP_MULTI;
  1805. X    stab_io(tmpstab) = stio_new();
  1806. X    stab_io(tmpstab)->ofp = stab_io(tmpstab)->ifp = stdout;
  1807. X    defoutstab = tmpstab;
  1808. X    tmpstab = stabent("stdout",TRUE);
  1809. X    stab_io(tmpstab) = stab_io(defoutstab);
  1810. X    tmpstab->str_pok |= SP_MULTI;
  1811. X
  1812. X    curoutstab = stabent("STDERR",TRUE);
  1813. X    curoutstab->str_pok |= SP_MULTI;
  1814. X    stab_io(curoutstab) = stio_new();
  1815. X    stab_io(curoutstab)->ofp = stab_io(curoutstab)->ifp = stderr;
  1816. X    tmpstab = stabent("stderr",TRUE);
  1817. X    stab_io(tmpstab) = stab_io(curoutstab);
  1818. X    tmpstab->str_pok |= SP_MULTI;
  1819. X    curoutstab = defoutstab;        /* switch back to STDOUT */
  1820. X
  1821. X    statname = Str_new(66,0);        /* last filename we did stat on */
  1822. X
  1823. X    perldb = FALSE;        /* don't try to instrument evals */
  1824. X
  1825. X    if (dowarn) {
  1826. X    stab_check('A','Z');
  1827. X    stab_check('a','z');
  1828. X    }
  1829. X
  1830. X    if (do_undump)
  1831. X    abort();
  1832. X
  1833. X  just_doit:        /* come here if running an undumped a.out */
  1834. X    argc--,argv++;    /* skip name of script */
  1835. X    if (doswitches) {
  1836. X    for (; argc > 0 && **argv == '-'; argc--,argv++) {
  1837. X        if (argv[0][1] == '-') {
  1838. X        argc--,argv++;
  1839. X        break;
  1840. X        }
  1841. X        str_numset(stab_val(stabent(argv[0]+1,TRUE)),(double)1.0);
  1842. X    }
  1843. X    }
  1844. X#ifdef TAINT
  1845. X    tainted = 1;
  1846. X#endif
  1847. X    if (argvstab = stabent("ARGV",allstabs)) {
  1848. X    argvstab->str_pok |= SP_MULTI;
  1849. X    (void)aadd(argvstab);
  1850. X    for (; argc > 0; argc--,argv++) {
  1851. X        (void)apush(stab_array(argvstab),str_make(argv[0],0));
  1852. X    }
  1853. X    }
  1854. X#ifdef TAINT
  1855. X    (void) stabent("ENV",TRUE);        /* must test PATH and IFS */
  1856. X#endif
  1857. X    if (envstab = stabent("ENV",allstabs)) {
  1858. X    envstab->str_pok |= SP_MULTI;
  1859. X    (void)hadd(envstab);
  1860. X    for (; *env; env++) {
  1861. X        if (!(s = index(*env,'=')))
  1862. X        continue;
  1863. X        *s++ = '\0';
  1864. X        str = str_make(s--,0);
  1865. X        str_magic(str, envstab, 'E', *env, s - *env);
  1866. X        (void)hstore(stab_hash(envstab), *env, s - *env, str, 0);
  1867. X        *s = '=';
  1868. X    }
  1869. X    }
  1870. X#ifdef TAINT
  1871. X    tainted = 0;
  1872. X#endif
  1873. X    if (tmpstab = stabent("$",allstabs))
  1874. X    str_numset(STAB_STR(tmpstab),(double)getpid());
  1875. X
  1876. X    if (setjmp(top_env))    /* sets goto_targ on longjump */
  1877. X    loop_ptr = 0;        /* start label stack again */
  1878. X
  1879. X#ifdef DEBUGGING
  1880. X    if (debug & 1024)
  1881. X    dump_all();
  1882. X    if (debug)
  1883. X    fprintf(stderr,"\nEXECUTING...\n\n");
  1884. X#endif
  1885. X
  1886. X    /* do it */
  1887. X
  1888. X    (void) cmd_exec(main_root,G_SCALAR,-1);
  1889. X
  1890. X    if (goto_targ)
  1891. X    fatal("Can't find label \"%s\"--aborting",goto_targ);
  1892. X    exit(0);
  1893. X    /* NOTREACHED */
  1894. X}
  1895. X
  1896. Xmagicalize(list)
  1897. Xregister char *list;
  1898. X{
  1899. X    register STAB *stab;
  1900. X    char sym[2];
  1901. X
  1902. X    sym[1] = '\0';
  1903. X    while (*sym = *list++) {
  1904. X    if (stab = stabent(sym,allstabs)) {
  1905. X        stab_flags(stab) = SF_VMAGIC;
  1906. X        str_magic(stab_val(stab), stab, 0, Nullch, 0);
  1907. X    }
  1908. X    }
  1909. X}
  1910. X
  1911. X/* this routine is in perly.c by virtue of being sort of an alternate main() */
  1912. X
  1913. Xint
  1914. Xdo_eval(str,optype,stash,gimme,arglast)
  1915. XSTR *str;
  1916. Xint optype;
  1917. XHASH *stash;
  1918. Xint gimme;
  1919. Xint *arglast;
  1920. X{
  1921. X    STR **st = stack->ary_array;
  1922. X    int retval;
  1923. X    CMD *myroot;
  1924. X    ARRAY *ar;
  1925. X    int i;
  1926. X    char *oldfile = filename;
  1927. X    line_t oldline = line;
  1928. X    int oldtmps_base = tmps_base;
  1929. X    int oldsave = savestack->ary_fill;
  1930. X    SPAT *oldspat = curspat;
  1931. X    static char *last_eval = Nullch;
  1932. X    static CMD *last_root = Nullcmd;
  1933. X    int sp = arglast[0];
  1934. X
  1935. X    tmps_base = tmps_max;
  1936. X    if (curstash != stash) {
  1937. X    (void)savehptr(&curstash);
  1938. X    curstash = stash;
  1939. X    }
  1940. X    str_set(stab_val(stabent("@",TRUE)),"");
  1941. X    if (optype != O_DOFILE) {    /* normal eval */
  1942. X    filename = "(eval)";
  1943. X    line = 1;
  1944. X    str_sset(linestr,str);
  1945. X    str_cat(linestr,";");        /* be kind to them */
  1946. X    }
  1947. X    else {
  1948. X    if (last_root) {
  1949. X        Safefree(last_eval);
  1950. X        cmd_free(last_root);
  1951. X        last_root = Nullcmd;
  1952. X    }
  1953. X    filename = savestr(str_get(str));    /* can't free this easily */
  1954. X    str_set(linestr,"");
  1955. X    rsfp = fopen(filename,"r");
  1956. X    ar = stab_array(incstab);
  1957. X    if (!rsfp && *filename != '/') {
  1958. X        for (i = 0; i <= ar->ary_fill; i++) {
  1959. X        (void)sprintf(buf,"%s/%s",str_get(afetch(ar,i,TRUE)),filename);
  1960. X        rsfp = fopen(buf,"r");
  1961. X        if (rsfp) {
  1962. X            filename = savestr(buf);
  1963. X            break;
  1964. X        }
  1965. X        }
  1966. X    }
  1967. X    if (!rsfp) {
  1968. X        filename = oldfile;
  1969. X        tmps_base = oldtmps_base;
  1970. X        if (gimme != G_ARRAY)
  1971. X        st[++sp] = &str_undef;
  1972. X        return sp;
  1973. X    }
  1974. X    line = 0;
  1975. X    }
  1976. X    in_eval++;
  1977. X    oldoldbufptr = oldbufptr = bufptr = str_get(linestr);
  1978. X    bufend = bufptr + linestr->str_cur;
  1979. X    if (setjmp(eval_env)) {
  1980. X    retval = 1;
  1981. X    last_root = Nullcmd;
  1982. X    }
  1983. X    else {
  1984. X    error_count = 0;
  1985. X    if (rsfp)
  1986. X        retval = yyparse();
  1987. X    else if (last_root && *bufptr == *last_eval && strEQ(bufptr,last_eval)){
  1988. X        retval = 0;
  1989. X        eval_root = last_root;    /* no point in reparsing */
  1990. X    }
  1991. X    else if (in_eval == 1) {
  1992. X        if (last_root) {
  1993. X        Safefree(last_eval);
  1994. X        cmd_free(last_root);
  1995. X        }
  1996. X        last_eval = savestr(bufptr);
  1997. X        last_root = Nullcmd;
  1998. X        retval = yyparse();
  1999. X        if (!retval)
  2000. X        last_root = eval_root;
  2001. X    }
  2002. X    else
  2003. X        retval = yyparse();
  2004. X    }
  2005. X    myroot = eval_root;        /* in case cmd_exec does another eval! */
  2006. X    if (retval || error_count) {
  2007. X    str = &str_undef;
  2008. X    last_root = Nullcmd;    /* can't free on error, for some reason */
  2009. X    if (rsfp) {
  2010. X        fclose(rsfp);
  2011. X        rsfp = 0;
  2012. X    }
  2013. X    }
  2014. X    else {
  2015. X    sp = cmd_exec(eval_root,gimme,sp);
  2016. X    st = stack->ary_array;
  2017. X    for (i = arglast[0] + 1; i <= sp; i++)
  2018. X        st[i] = str_static(st[i]);
  2019. X                /* if we don't save result, free zaps it */
  2020. X    if (in_eval != 1 && myroot != last_root)
  2021. X        cmd_free(myroot);
  2022. X    }
  2023. X    in_eval--;
  2024. X    filename = oldfile;
  2025. X    line = oldline;
  2026. X    tmps_base = oldtmps_base;
  2027. X    curspat = oldspat;
  2028. X    if (savestack->ary_fill > oldsave)    /* let them use local() */
  2029. X    restorelist(oldsave);
  2030. X    return sp;
  2031. X}
  2032. !STUFFY!FUNK!
  2033. echo Extracting eg/findcp
  2034. sed >eg/findcp <<'!STUFFY!FUNK!' -e 's/X//'
  2035. X#!/usr/bin/perl
  2036. X
  2037. X# $Header: findcp,v 3.0 89/10/18 15:13:47 lwall Locked $
  2038. X
  2039. X# This is a wrapper around the find command that pretends find has a switch
  2040. X# of the form -cp host:destination.  It presumes your find implements -ls.
  2041. X# It uses tar to do the actual copy.  If your tar knows about the I switch
  2042. X# you may prefer to use findtar, since this one has to do the tar in batches.
  2043. X
  2044. Xsub copy {
  2045. X    `tar cf - $list | rsh $desthost cd $destdir '&&' tar xBpf -`;
  2046. X}
  2047. X
  2048. X$sourcedir = $ARGV[0];
  2049. Xif ($sourcedir =~ /^\//) {
  2050. X    $ARGV[0] = '.';
  2051. X    unless (chdir($sourcedir)) { die "Can't find directory $sourcedir: $!"; }
  2052. X}
  2053. X
  2054. X$args = join(' ',@ARGV);
  2055. Xif ($args =~ s/-cp *([^ ]+)/-ls/) {
  2056. X    $dest = $1;
  2057. X    if ($dest =~ /(.*):(.*)/) {
  2058. X    $desthost = $1;
  2059. X    $destdir = $2;
  2060. X    }
  2061. X    else {
  2062. X    die "Malformed destination--should be host:directory";
  2063. X    }
  2064. X}
  2065. Xelse {
  2066. X    die("No destination specified");
  2067. X}
  2068. X
  2069. Xopen(find,"find $args |") || die "Can't run find for you: $!";
  2070. X
  2071. Xwhile (<find>) {
  2072. X    @x = split(' ');
  2073. X    if ($x[2] =~ /^d/) { next;}
  2074. X    chop($filename = $x[10]);
  2075. X    if (length($list) > 5000) {
  2076. X    do copy();
  2077. X    $list = '';
  2078. X    }
  2079. X    else {
  2080. X    $list .= ' ';
  2081. X    }
  2082. X    $list .= $filename;
  2083. X}
  2084. X
  2085. Xif ($list) {
  2086. X    do copy();
  2087. X}
  2088. !STUFFY!FUNK!
  2089. echo ""
  2090. echo "End of kit 17 (of 24)"
  2091. cat /dev/null >kit17isdone
  2092. run=''
  2093. config=''
  2094. 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; do
  2095.     if test -f kit${iskit}isdone; then
  2096.     run="$run $iskit"
  2097.     else
  2098.     todo="$todo $iskit"
  2099.     fi
  2100. done
  2101. case $todo in
  2102.     '')
  2103.     echo "You have run all your kits.  Please read README and then type Configure."
  2104.     chmod 755 Configure
  2105.     ;;
  2106.     *)  echo "You have run$run."
  2107.     echo "You still need to run$todo."
  2108.     ;;
  2109. esac
  2110. : Someone might mail this, so...
  2111. exit
  2112.  
  2113.