home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1994 October / usenetsourcesnewsgroupsinfomagicoctober1994disk2.iso / misc / volume18 / perl / part11 < prev    next >
Encoding:
Internet Message Format  |  1991-04-15  |  49.6 KB
  1. From: lwall@netlabs.com (Larry Wall)
  2. Newsgroups: comp.sources.misc
  3. Subject: v18i029:  perl - The perl programming language, Part11/36
  4. Message-ID: <1991Apr16.000020.22784@sparky.IMD.Sterling.COM>
  5. Date: 16 Apr 91 00:00:20 GMT
  6. Approved: kent@sparky.imd.sterling.com
  7. X-Checksum-Snefru: 251cdcb0 028ad940 e6affd4b 12d93fb4
  8.  
  9. Submitted-by: Larry Wall <lwall@netlabs.com>
  10. Posting-number: Volume 18, Issue 29
  11. Archive-name: perl/part11
  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 11 (of 36).  If kit 11 is complete, the line"
  21. echo '"'"End of kit 11 (of 36)"'" will echo at the end.'
  22. echo ""
  23. export PATH || (echo "You didn't use sh, you clunch." ; kill $$)
  24. mkdir  2>/dev/null
  25. echo Extracting dolist.c
  26. sed >dolist.c <<'!STUFFY!FUNK!' -e 's/X//'
  27. X/* $Header: dolist.c,v 4.0 91/03/20 01:08:03 lwall Locked $
  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:    dolist.c,v $
  35. X * Revision 4.0  91/03/20  01:08:03  lwall
  36. X * 4.0 baseline.
  37. X * 
  38. X */
  39. X
  40. X#include "EXTERN.h"
  41. X#include "perl.h"
  42. X
  43. X
  44. X#ifdef BUGGY_MSC
  45. X #pragma function(memcmp)
  46. X#endif /* BUGGY_MSC */
  47. X
  48. Xint
  49. Xdo_match(str,arg,gimme,arglast)
  50. XSTR *str;
  51. Xregister ARG *arg;
  52. Xint gimme;
  53. Xint *arglast;
  54. X{
  55. X    register STR **st = stack->ary_array;
  56. X    register SPAT *spat = arg[2].arg_ptr.arg_spat;
  57. X    register char *t;
  58. X    register int sp = arglast[0] + 1;
  59. X    STR *srchstr = st[sp];
  60. X    register char *s = str_get(st[sp]);
  61. X    char *strend = s + st[sp]->str_cur;
  62. X    STR *tmpstr;
  63. X    char *myhint = hint;
  64. X
  65. X    hint = Nullch;
  66. X    if (!spat) {
  67. X    if (gimme == G_ARRAY)
  68. X        return --sp;
  69. X    str_set(str,Yes);
  70. X    STABSET(str);
  71. X    st[sp] = str;
  72. X    return sp;
  73. X    }
  74. X    if (!s)
  75. X    fatal("panic: do_match");
  76. X    if (spat->spat_flags & SPAT_USED) {
  77. X#ifdef DEBUGGING
  78. X    if (debug & 8)
  79. X        deb("2.SPAT USED\n");
  80. X#endif
  81. X    if (gimme == G_ARRAY)
  82. X        return --sp;
  83. X    str_set(str,No);
  84. X    STABSET(str);
  85. X    st[sp] = str;
  86. X    return sp;
  87. X    }
  88. X    --sp;
  89. X    if (spat->spat_runtime) {
  90. X    nointrp = "|)";
  91. X    sp = eval(spat->spat_runtime,G_SCALAR,sp);
  92. X    st = stack->ary_array;
  93. X    t = str_get(tmpstr = st[sp--]);
  94. X    nointrp = "";
  95. X#ifdef DEBUGGING
  96. X    if (debug & 8)
  97. X        deb("2.SPAT /%s/\n",t);
  98. X#endif
  99. X    if (spat->spat_regexp) {
  100. X        regfree(spat->spat_regexp);
  101. X        spat->spat_regexp = Null(REGEXP*);    /* crucial if regcomp aborts */
  102. X    }
  103. X    spat->spat_regexp = regcomp(t,t+tmpstr->str_cur,
  104. X        spat->spat_flags & SPAT_FOLD);
  105. X    if (!*spat->spat_regexp->precomp && lastspat)
  106. X        spat = lastspat;
  107. X    if (spat->spat_flags & SPAT_KEEP) {
  108. X        if (spat->spat_runtime)
  109. X        arg_free(spat->spat_runtime);    /* it won't change, so */
  110. X        spat->spat_runtime = Nullarg;    /* no point compiling again */
  111. X    }
  112. X    if (!spat->spat_regexp->nparens)
  113. X        gimme = G_SCALAR;            /* accidental array context? */
  114. X    if (regexec(spat->spat_regexp, s, strend, s, 0,
  115. X      srchstr->str_pok & SP_STUDIED ? srchstr : Nullstr,
  116. X      gimme == G_ARRAY)) {
  117. X        if (spat->spat_regexp->subbase)
  118. X        curspat = spat;
  119. X        lastspat = spat;
  120. X        goto gotcha;
  121. X    }
  122. X    else {
  123. X        if (gimme == G_ARRAY)
  124. X        return sp;
  125. X        str_sset(str,&str_no);
  126. X        STABSET(str);
  127. X        st[++sp] = str;
  128. X        return sp;
  129. X    }
  130. X    }
  131. X    else {
  132. X#ifdef DEBUGGING
  133. X    if (debug & 8) {
  134. X        char ch;
  135. X
  136. X        if (spat->spat_flags & SPAT_ONCE)
  137. X        ch = '?';
  138. X        else
  139. X        ch = '/';
  140. X        deb("2.SPAT %c%s%c\n",ch,spat->spat_regexp->precomp,ch);
  141. X    }
  142. X#endif
  143. X    if (!*spat->spat_regexp->precomp && lastspat)
  144. X        spat = lastspat;
  145. X    t = s;
  146. X    if (myhint) {
  147. X        if (myhint < s || myhint > strend)
  148. X        fatal("panic: hint in do_match");
  149. X        s = myhint;
  150. X        if (spat->spat_regexp->regback >= 0) {
  151. X        s -= spat->spat_regexp->regback;
  152. X        if (s < t)
  153. X            s = t;
  154. X        }
  155. X        else
  156. X        s = t;
  157. X    }
  158. X    else if (spat->spat_short) {
  159. X        if (spat->spat_flags & SPAT_SCANFIRST) {
  160. X        if (srchstr->str_pok & SP_STUDIED) {
  161. X            if (screamfirst[spat->spat_short->str_rare] < 0)
  162. X            goto nope;
  163. X            else if (!(s = screaminstr(srchstr,spat->spat_short)))
  164. X            goto nope;
  165. X            else if (spat->spat_flags & SPAT_ALL)
  166. X            goto yup;
  167. X        }
  168. X#ifndef lint
  169. X        else if (!(s = fbminstr((unsigned char*)s,
  170. X          (unsigned char*)strend, spat->spat_short)))
  171. X            goto nope;
  172. X#endif
  173. X        else if (spat->spat_flags & SPAT_ALL)
  174. X            goto yup;
  175. X        if (s && spat->spat_regexp->regback >= 0) {
  176. X            ++spat->spat_short->str_u.str_useful;
  177. X            s -= spat->spat_regexp->regback;
  178. X            if (s < t)
  179. X            s = t;
  180. X        }
  181. X        else
  182. X            s = t;
  183. X        }
  184. X        else if (!multiline && (*spat->spat_short->str_ptr != *s ||
  185. X          bcmp(spat->spat_short->str_ptr, s, spat->spat_slen) ))
  186. X        goto nope;
  187. X        if (--spat->spat_short->str_u.str_useful < 0) {
  188. X        str_free(spat->spat_short);
  189. X        spat->spat_short = Nullstr;    /* opt is being useless */
  190. X        }
  191. X    }
  192. X    if (!spat->spat_regexp->nparens)
  193. X        gimme = G_SCALAR;            /* accidental array context? */
  194. X    if (regexec(spat->spat_regexp, s, strend, t, 0,
  195. X      srchstr->str_pok & SP_STUDIED ? srchstr : Nullstr,
  196. X      gimme == G_ARRAY)) {
  197. X        if (spat->spat_regexp->subbase)
  198. X        curspat = spat;
  199. X        lastspat = spat;
  200. X        if (spat->spat_flags & SPAT_ONCE)
  201. X        spat->spat_flags |= SPAT_USED;
  202. X        goto gotcha;
  203. X    }
  204. X    else {
  205. X        if (gimme == G_ARRAY)
  206. X        return sp;
  207. X        str_sset(str,&str_no);
  208. X        STABSET(str);
  209. X        st[++sp] = str;
  210. X        return sp;
  211. X    }
  212. X    }
  213. X    /*NOTREACHED*/
  214. X
  215. X  gotcha:
  216. X    if (gimme == G_ARRAY) {
  217. X    int iters, i, len;
  218. X
  219. X    iters = spat->spat_regexp->nparens;
  220. X    if (sp + iters >= stack->ary_max) {
  221. X        astore(stack,sp + iters, Nullstr);
  222. X        st = stack->ary_array;        /* possibly realloced */
  223. X    }
  224. X
  225. X    for (i = 1; i <= iters; i++) {
  226. X        st[++sp] = str_mortal(&str_no);
  227. X        if (s = spat->spat_regexp->startp[i]) {
  228. X        len = spat->spat_regexp->endp[i] - s;
  229. X        if (len > 0)
  230. X            str_nset(st[sp],s,len);
  231. X        }
  232. X    }
  233. X    return sp;
  234. X    }
  235. X    else {
  236. X    str_sset(str,&str_yes);
  237. X    STABSET(str);
  238. X    st[++sp] = str;
  239. X    return sp;
  240. X    }
  241. X
  242. Xyup:
  243. X    ++spat->spat_short->str_u.str_useful;
  244. X    lastspat = spat;
  245. X    if (spat->spat_flags & SPAT_ONCE)
  246. X    spat->spat_flags |= SPAT_USED;
  247. X    if (sawampersand) {
  248. X    char *tmps;
  249. X
  250. X    if (spat->spat_regexp->subbase)
  251. X        Safefree(spat->spat_regexp->subbase);
  252. X    tmps = spat->spat_regexp->subbase = nsavestr(t,strend-t);
  253. X    spat->spat_regexp->subend = tmps + (strend-t);
  254. X    tmps = spat->spat_regexp->startp[0] = tmps + (s - t);
  255. X    spat->spat_regexp->endp[0] = tmps + spat->spat_short->str_cur;
  256. X    curspat = spat;
  257. X    }
  258. X    str_sset(str,&str_yes);
  259. X    STABSET(str);
  260. X    st[++sp] = str;
  261. X    return sp;
  262. X
  263. Xnope:
  264. X    ++spat->spat_short->str_u.str_useful;
  265. X    if (gimme == G_ARRAY)
  266. X    return sp;
  267. X    str_sset(str,&str_no);
  268. X    STABSET(str);
  269. X    st[++sp] = str;
  270. X    return sp;
  271. X}
  272. X
  273. X#ifdef BUGGY_MSC
  274. X #pragma intrinsic(memcmp)
  275. X#endif /* BUGGY_MSC */
  276. X
  277. Xint
  278. Xdo_split(str,spat,limit,gimme,arglast)
  279. XSTR *str;
  280. Xregister SPAT *spat;
  281. Xregister int limit;
  282. Xint gimme;
  283. Xint *arglast;
  284. X{
  285. X    register ARRAY *ary = stack;
  286. X    STR **st = ary->ary_array;
  287. X    register int sp = arglast[0] + 1;
  288. X    register char *s = str_get(st[sp]);
  289. X    char *strend = s + st[sp--]->str_cur;
  290. X    register STR *dstr;
  291. X    register char *m;
  292. X    int iters = 0;
  293. X    int maxiters = (strend - s) + 10;
  294. X    int i;
  295. X    char *orig;
  296. X    int origlimit = limit;
  297. X    int realarray = 0;
  298. X
  299. X    if (!spat || !s)
  300. X    fatal("panic: do_split");
  301. X    else if (spat->spat_runtime) {
  302. X    nointrp = "|)";
  303. X    sp = eval(spat->spat_runtime,G_SCALAR,sp);
  304. X    st = stack->ary_array;
  305. X    m = str_get(dstr = st[sp--]);
  306. X    nointrp = "";
  307. X    if (*m == ' ' && dstr->str_cur == 1) {
  308. X        str_set(dstr,"\\s+");
  309. X        m = dstr->str_ptr;
  310. X        spat->spat_flags |= SPAT_SKIPWHITE;
  311. X    }
  312. X    if (spat->spat_regexp) {
  313. X        regfree(spat->spat_regexp);
  314. X        spat->spat_regexp = Null(REGEXP*);    /* avoid possible double free */
  315. X    }
  316. X    spat->spat_regexp = regcomp(m,m+dstr->str_cur,
  317. X        spat->spat_flags & SPAT_FOLD);
  318. X    if (spat->spat_flags & SPAT_KEEP ||
  319. X        (spat->spat_runtime->arg_type == O_ITEM &&
  320. X          (spat->spat_runtime[1].arg_type & A_MASK) == A_SINGLE) ) {
  321. X        arg_free(spat->spat_runtime);    /* it won't change, so */
  322. X        spat->spat_runtime = Nullarg;    /* no point compiling again */
  323. X    }
  324. X    }
  325. X#ifdef DEBUGGING
  326. X    if (debug & 8) {
  327. X    deb("2.SPAT /%s/\n",spat->spat_regexp->precomp);
  328. X    }
  329. X#endif
  330. X    ary = stab_xarray(spat->spat_repl[1].arg_ptr.arg_stab);
  331. X    if (ary && (gimme != G_ARRAY || (spat->spat_flags & SPAT_ONCE))) {
  332. X    realarray = 1;
  333. X    if (!(ary->ary_flags & ARF_REAL)) {
  334. X        ary->ary_flags |= ARF_REAL;
  335. X        for (i = ary->ary_fill; i >= 0; i--)
  336. X        ary->ary_array[i] = Nullstr;    /* don't free mere refs */
  337. X    }
  338. X    ary->ary_fill = -1;
  339. X    sp = -1;    /* temporarily switch stacks */
  340. X    }
  341. X    else
  342. X    ary = stack;
  343. X    orig = s;
  344. X    if (spat->spat_flags & SPAT_SKIPWHITE) {
  345. X    while (isascii(*s) && isspace(*s))
  346. X        s++;
  347. X    }
  348. X    if (!limit)
  349. X    limit = maxiters + 2;
  350. X    if (strEQ("\\s+",spat->spat_regexp->precomp)) {
  351. X    while (--limit) {
  352. X        for (m = s; m < strend && !(isascii(*m)&&isspace(*m)); m++) ;
  353. X        if (m >= strend)
  354. X        break;
  355. X        dstr = Str_new(30,m-s);
  356. X        str_nset(dstr,s,m-s);
  357. X        if (!realarray)
  358. X        str_2mortal(dstr);
  359. X        (void)astore(ary, ++sp, dstr);
  360. X        for (s = m + 1; s < strend && isascii(*s) && isspace(*s); s++) ;
  361. X    }
  362. X    }
  363. X    else if (strEQ("^",spat->spat_regexp->precomp)) {
  364. X    while (--limit) {
  365. X        for (m = s; m < strend && *m != '\n'; m++) ;
  366. X        m++;
  367. X        if (m >= strend)
  368. X        break;
  369. X        dstr = Str_new(30,m-s);
  370. X        str_nset(dstr,s,m-s);
  371. X        if (!realarray)
  372. X        str_2mortal(dstr);
  373. X        (void)astore(ary, ++sp, dstr);
  374. X        s = m;
  375. X    }
  376. X    }
  377. X    else if (spat->spat_short) {
  378. X    i = spat->spat_short->str_cur;
  379. X    if (i == 1) {
  380. X        int fold = (spat->spat_flags & SPAT_FOLD);
  381. X
  382. X        i = *spat->spat_short->str_ptr;
  383. X        if (fold && isupper(i))
  384. X        i = tolower(i);
  385. X        while (--limit) {
  386. X        if (fold) {
  387. X            for ( m = s;
  388. X              m < strend && *m != i &&
  389. X                (!isupper(*m) || tolower(*m) != i);
  390. X              m++)
  391. X            ;
  392. X        }
  393. X        else
  394. X            for (m = s; m < strend && *m != i; m++) ;
  395. X        if (m >= strend)
  396. X            break;
  397. X        dstr = Str_new(30,m-s);
  398. X        str_nset(dstr,s,m-s);
  399. X        if (!realarray)
  400. X            str_2mortal(dstr);
  401. X        (void)astore(ary, ++sp, dstr);
  402. X        s = m + 1;
  403. X        }
  404. X    }
  405. X    else {
  406. X#ifndef lint
  407. X        while (s < strend && --limit &&
  408. X          (m=fbminstr((unsigned char*)s, (unsigned char*)strend,
  409. X            spat->spat_short)) )
  410. X#endif
  411. X        {
  412. X        dstr = Str_new(31,m-s);
  413. X        str_nset(dstr,s,m-s);
  414. X        if (!realarray)
  415. X            str_2mortal(dstr);
  416. X        (void)astore(ary, ++sp, dstr);
  417. X        s = m + i;
  418. X        }
  419. X    }
  420. X    }
  421. X    else {
  422. X    maxiters += (strend - s) * spat->spat_regexp->nparens;
  423. X    while (s < strend && --limit &&
  424. X        regexec(spat->spat_regexp, s, strend, orig, 1, Nullstr, TRUE) ) {
  425. X        if (spat->spat_regexp->subbase
  426. X          && spat->spat_regexp->subbase != orig) {
  427. X        m = s;
  428. X        s = orig;
  429. X        orig = spat->spat_regexp->subbase;
  430. X        s = orig + (m - s);
  431. X        strend = s + (strend - m);
  432. X        }
  433. X        m = spat->spat_regexp->startp[0];
  434. X        dstr = Str_new(32,m-s);
  435. X        str_nset(dstr,s,m-s);
  436. X        if (!realarray)
  437. X        str_2mortal(dstr);
  438. X        (void)astore(ary, ++sp, dstr);
  439. X        if (spat->spat_regexp->nparens) {
  440. X        for (i = 1; i <= spat->spat_regexp->nparens; i++) {
  441. X            s = spat->spat_regexp->startp[i];
  442. X            m = spat->spat_regexp->endp[i];
  443. X            dstr = Str_new(33,m-s);
  444. X            str_nset(dstr,s,m-s);
  445. X            if (!realarray)
  446. X            str_2mortal(dstr);
  447. X            (void)astore(ary, ++sp, dstr);
  448. X        }
  449. X        }
  450. X        s = spat->spat_regexp->endp[0];
  451. X    }
  452. X    }
  453. X    if (realarray)
  454. X    iters = sp + 1;
  455. X    else
  456. X    iters = sp - arglast[0];
  457. X    if (iters > maxiters)
  458. X    fatal("Split loop");
  459. X    if (s < strend || origlimit) {    /* keep field after final delim? */
  460. X    dstr = Str_new(34,strend-s);
  461. X    str_nset(dstr,s,strend-s);
  462. X    if (!realarray)
  463. X        str_2mortal(dstr);
  464. X    (void)astore(ary, ++sp, dstr);
  465. X    iters++;
  466. X    }
  467. X    else {
  468. X#ifndef I286x
  469. X    while (iters > 0 && ary->ary_array[sp]->str_cur == 0)
  470. X        iters--,sp--;
  471. X#else
  472. X    char *zaps;
  473. X    int   zapb;
  474. X
  475. X    if (iters > 0) {
  476. X        zaps = str_get(afetch(ary,sp,FALSE));
  477. X        zapb = (int) *zaps;
  478. X    }
  479. X    
  480. X    while (iters > 0 && (!zapb)) {
  481. X        iters--,sp--;
  482. X        if (iters > 0) {
  483. X        zaps = str_get(afetch(ary,iters-1,FALSE));
  484. X        zapb = (int) *zaps;
  485. X        }
  486. X    }
  487. X#endif
  488. X    }
  489. X    if (realarray) {
  490. X    ary->ary_fill = sp;
  491. X    if (gimme == G_ARRAY) {
  492. X        sp++;
  493. X        astore(stack, arglast[0] + 1 + sp, Nullstr);
  494. X        Copy(ary->ary_array, stack->ary_array + arglast[0] + 1, sp, STR*);
  495. X        return arglast[0] + sp;
  496. X    }
  497. X    }
  498. X    else {
  499. X    if (gimme == G_ARRAY)
  500. X        return sp;
  501. X    }
  502. X    sp = arglast[0] + 1;
  503. X    str_numset(str,(double)iters);
  504. X    STABSET(str);
  505. X    st[sp] = str;
  506. X    return sp;
  507. X}
  508. X
  509. Xint
  510. Xdo_unpack(str,gimme,arglast)
  511. XSTR *str;
  512. Xint gimme;
  513. Xint *arglast;
  514. X{
  515. X    STR **st = stack->ary_array;
  516. X    register int sp = arglast[0] + 1;
  517. X    register char *pat = str_get(st[sp++]);
  518. X    register char *s = str_get(st[sp]);
  519. X    char *strend = s + st[sp--]->str_cur;
  520. X    char *strbeg = s;
  521. X    register char *patend = pat + st[sp]->str_cur;
  522. X    int datumtype;
  523. X    register int len;
  524. X    register int bits;
  525. X
  526. X    /* These must not be in registers: */
  527. X    short ashort;
  528. X    int aint;
  529. X    long along;
  530. X    unsigned short aushort;
  531. X    unsigned int auint;
  532. X    unsigned long aulong;
  533. X    char *aptr;
  534. X    float afloat;
  535. X    double adouble;
  536. X    int checksum = 0;
  537. X    unsigned long culong;
  538. X    double cdouble;
  539. X
  540. X    if (gimme != G_ARRAY) {        /* arrange to do first one only */
  541. X    for (patend = pat; !isalpha(*patend); patend++);
  542. X    if (index("aAbBhH", *patend) || *pat == '%') {
  543. X        patend++;
  544. X        while (isdigit(*patend) || *patend == '*')
  545. X        patend++;
  546. X    }
  547. X    else
  548. X        patend++;
  549. X    }
  550. X    sp--;
  551. X    while (pat < patend) {
  552. X      reparse:
  553. X    datumtype = *pat++;
  554. X    if (pat >= patend)
  555. X        len = 1;
  556. X    else if (*pat == '*') {
  557. X        len = strend - strbeg;    /* long enough */
  558. X        pat++;
  559. X    }
  560. X    else if (isdigit(*pat)) {
  561. X        len = *pat++ - '0';
  562. X        while (isdigit(*pat))
  563. X        len = (len * 10) + (*pat++ - '0');
  564. X    }
  565. X    else
  566. X        len = (datumtype != '@');
  567. X    switch(datumtype) {
  568. X    default:
  569. X        break;
  570. X    case '%':
  571. X        if (len == 1 && pat[-1] != '1')
  572. X        len = 16;
  573. X        checksum = len;
  574. X        culong = 0;
  575. X        cdouble = 0;
  576. X        if (pat < patend)
  577. X        goto reparse;
  578. X        break;
  579. X    case '@':
  580. X        if (len > strend - s)
  581. X        fatal("@ outside of string");
  582. X        s = strbeg + len;
  583. X        break;
  584. X    case 'X':
  585. X        if (len > s - strbeg)
  586. X        fatal("X outside of string");
  587. X        s -= len;
  588. X        break;
  589. X    case 'x':
  590. X        if (len > strend - s)
  591. X        fatal("x outside of string");
  592. X        s += len;
  593. X        break;
  594. X    case 'A':
  595. X    case 'a':
  596. X        if (len > strend - s)
  597. X        len = strend - s;
  598. X        if (checksum)
  599. X        goto uchar_checksum;
  600. X        str = Str_new(35,len);
  601. X        str_nset(str,s,len);
  602. X        s += len;
  603. X        if (datumtype == 'A') {
  604. X        aptr = s;    /* borrow register */
  605. X        s = str->str_ptr + len - 1;
  606. X        while (s >= str->str_ptr && (!*s || (isascii(*s)&&isspace(*s))))
  607. X            s--;
  608. X        *++s = '\0';
  609. X        str->str_cur = s - str->str_ptr;
  610. X        s = aptr;    /* unborrow register */
  611. X        }
  612. X        (void)astore(stack, ++sp, str_2mortal(str));
  613. X        break;
  614. X    case 'B':
  615. X    case 'b':
  616. X        if (pat[-1] == '*' || len > (strend - s) * 8)
  617. X        len = (strend - s) * 8;
  618. X        str = Str_new(35, len + 1);
  619. X        str->str_cur = len;
  620. X        str->str_pok = 1;
  621. X        aptr = pat;            /* borrow register */
  622. X        pat = str->str_ptr;
  623. X        if (datumtype == 'b') {
  624. X        aint = len;
  625. X        for (len = 0; len < aint; len++) {
  626. X            if (len & 7)
  627. X            bits >>= 1;
  628. X            else
  629. X            bits = *s++;
  630. X            *pat++ = '0' + (bits & 1);
  631. X        }
  632. X        }
  633. X        else {
  634. X        aint = len;
  635. X        for (len = 0; len < aint; len++) {
  636. X            if (len & 7)
  637. X            bits <<= 1;
  638. X            else
  639. X            bits = *s++;
  640. X            *pat++ = '0' + ((bits & 128) != 0);
  641. X        }
  642. X        }
  643. X        *pat = '\0';
  644. X        pat = aptr;            /* unborrow register */
  645. X        (void)astore(stack, ++sp, str_2mortal(str));
  646. X        break;
  647. X    case 'H':
  648. X    case 'h':
  649. X        if (pat[-1] == '*' || len > (strend - s) * 2)
  650. X        len = (strend - s) * 2;
  651. X        str = Str_new(35, len + 1);
  652. X        str->str_cur = len;
  653. X        str->str_pok = 1;
  654. X        aptr = pat;            /* borrow register */
  655. X        pat = str->str_ptr;
  656. X        if (datumtype == 'h') {
  657. X        aint = len;
  658. X        for (len = 0; len < aint; len++) {
  659. X            if (len & 1)
  660. X            bits >>= 4;
  661. X            else
  662. X            bits = *s++;
  663. X            *pat++ = hexdigit[bits & 15];
  664. X        }
  665. X        }
  666. X        else {
  667. X        aint = len;
  668. X        for (len = 0; len < aint; len++) {
  669. X            if (len & 1)
  670. X            bits <<= 4;
  671. X            else
  672. X            bits = *s++;
  673. X            *pat++ = hexdigit[(bits >> 4) & 15];
  674. X        }
  675. X        }
  676. X        *pat = '\0';
  677. X        pat = aptr;            /* unborrow register */
  678. X        (void)astore(stack, ++sp, str_2mortal(str));
  679. X        break;
  680. X    case 'c':
  681. X        if (len > strend - s)
  682. X        len = strend - s;
  683. X        if (checksum) {
  684. X        while (len-- > 0) {
  685. X            aint = *s++;
  686. X            if (aint >= 128)    /* fake up signed chars */
  687. X            aint -= 256;
  688. X            culong += aint;
  689. X        }
  690. X        }
  691. X        else {
  692. X        while (len-- > 0) {
  693. X            aint = *s++;
  694. X            if (aint >= 128)    /* fake up signed chars */
  695. X            aint -= 256;
  696. X            str = Str_new(36,0);
  697. X            str_numset(str,(double)aint);
  698. X            (void)astore(stack, ++sp, str_2mortal(str));
  699. X        }
  700. X        }
  701. X        break;
  702. X    case 'C':
  703. X        if (len > strend - s)
  704. X        len = strend - s;
  705. X        if (checksum) {
  706. X          uchar_checksum:
  707. X        while (len-- > 0) {
  708. X            auint = *s++ & 255;
  709. X            culong += auint;
  710. X        }
  711. X        }
  712. X        else {
  713. X        while (len-- > 0) {
  714. X            auint = *s++ & 255;
  715. X            str = Str_new(37,0);
  716. X            str_numset(str,(double)auint);
  717. X            (void)astore(stack, ++sp, str_2mortal(str));
  718. X        }
  719. X        }
  720. X        break;
  721. X    case 's':
  722. X        along = (strend - s) / sizeof(short);
  723. X        if (len > along)
  724. X        len = along;
  725. X        if (checksum) {
  726. X        while (len-- > 0) {
  727. X            bcopy(s,(char*)&ashort,sizeof(short));
  728. X            s += sizeof(short);
  729. X            culong += ashort;
  730. X        }
  731. X        }
  732. X        else {
  733. X        while (len-- > 0) {
  734. X            bcopy(s,(char*)&ashort,sizeof(short));
  735. X            s += sizeof(short);
  736. X            str = Str_new(38,0);
  737. X            str_numset(str,(double)ashort);
  738. X            (void)astore(stack, ++sp, str_2mortal(str));
  739. X        }
  740. X        }
  741. X        break;
  742. X    case 'n':
  743. X    case 'S':
  744. X        along = (strend - s) / sizeof(unsigned short);
  745. X        if (len > along)
  746. X        len = along;
  747. X        if (checksum) {
  748. X        while (len-- > 0) {
  749. X            bcopy(s,(char*)&aushort,sizeof(unsigned short));
  750. X            s += sizeof(unsigned short);
  751. X#ifdef HAS_NTOHS
  752. X            if (datumtype == 'n')
  753. X            aushort = ntohs(aushort);
  754. X#endif
  755. X            culong += aushort;
  756. X        }
  757. X        }
  758. X        else {
  759. X        while (len-- > 0) {
  760. X            bcopy(s,(char*)&aushort,sizeof(unsigned short));
  761. X            s += sizeof(unsigned short);
  762. X            str = Str_new(39,0);
  763. X#ifdef HAS_NTOHS
  764. X            if (datumtype == 'n')
  765. X            aushort = ntohs(aushort);
  766. X#endif
  767. X            str_numset(str,(double)aushort);
  768. X            (void)astore(stack, ++sp, str_2mortal(str));
  769. X        }
  770. X        }
  771. X        break;
  772. X    case 'i':
  773. X        along = (strend - s) / sizeof(int);
  774. X        if (len > along)
  775. X        len = along;
  776. X        if (checksum) {
  777. X        while (len-- > 0) {
  778. X            bcopy(s,(char*)&aint,sizeof(int));
  779. X            s += sizeof(int);
  780. X            if (checksum > 32)
  781. X            cdouble += (double)aint;
  782. X            else
  783. X            culong += aint;
  784. X        }
  785. X        }
  786. X        else {
  787. X        while (len-- > 0) {
  788. X            bcopy(s,(char*)&aint,sizeof(int));
  789. X            s += sizeof(int);
  790. X            str = Str_new(40,0);
  791. X            str_numset(str,(double)aint);
  792. X            (void)astore(stack, ++sp, str_2mortal(str));
  793. X        }
  794. X        }
  795. X        break;
  796. X    case 'I':
  797. X        along = (strend - s) / sizeof(unsigned int);
  798. X        if (len > along)
  799. X        len = along;
  800. X        if (checksum) {
  801. X        while (len-- > 0) {
  802. X            bcopy(s,(char*)&auint,sizeof(unsigned int));
  803. X            s += sizeof(unsigned int);
  804. X            if (checksum > 32)
  805. X            cdouble += (double)auint;
  806. X            else
  807. X            culong += auint;
  808. X        }
  809. X        }
  810. X        else {
  811. X        while (len-- > 0) {
  812. X            bcopy(s,(char*)&auint,sizeof(unsigned int));
  813. X            s += sizeof(unsigned int);
  814. X            str = Str_new(41,0);
  815. X            str_numset(str,(double)auint);
  816. X            (void)astore(stack, ++sp, str_2mortal(str));
  817. X        }
  818. X        }
  819. X        break;
  820. X    case 'l':
  821. X        along = (strend - s) / sizeof(long);
  822. X        if (len > along)
  823. X        len = along;
  824. X        if (checksum) {
  825. X        while (len-- > 0) {
  826. X            bcopy(s,(char*)&along,sizeof(long));
  827. X            s += sizeof(long);
  828. X            if (checksum > 32)
  829. X            cdouble += (double)along;
  830. X            else
  831. X            culong += along;
  832. X        }
  833. X        }
  834. X        else {
  835. X        while (len-- > 0) {
  836. X            bcopy(s,(char*)&along,sizeof(long));
  837. X            s += sizeof(long);
  838. X            str = Str_new(42,0);
  839. X            str_numset(str,(double)along);
  840. X            (void)astore(stack, ++sp, str_2mortal(str));
  841. X        }
  842. X        }
  843. X        break;
  844. X    case 'N':
  845. X    case 'L':
  846. X        along = (strend - s) / sizeof(unsigned long);
  847. X        if (len > along)
  848. X        len = along;
  849. X        if (checksum) {
  850. X        while (len-- > 0) {
  851. X            bcopy(s,(char*)&aulong,sizeof(unsigned long));
  852. X            s += sizeof(unsigned long);
  853. X#ifdef HAS_NTOHL
  854. X            if (datumtype == 'N')
  855. X            aulong = ntohl(aulong);
  856. X#endif
  857. X            if (checksum > 32)
  858. X            cdouble += (double)aulong;
  859. X            else
  860. X            culong += aulong;
  861. X        }
  862. X        }
  863. X        else {
  864. X        while (len-- > 0) {
  865. X            bcopy(s,(char*)&aulong,sizeof(unsigned long));
  866. X            s += sizeof(unsigned long);
  867. X            str = Str_new(43,0);
  868. X#ifdef HAS_NTOHL
  869. X            if (datumtype == 'N')
  870. X            aulong = ntohl(aulong);
  871. X#endif
  872. X            str_numset(str,(double)aulong);
  873. X            (void)astore(stack, ++sp, str_2mortal(str));
  874. X        }
  875. X        }
  876. X        break;
  877. X    case 'p':
  878. X        along = (strend - s) / sizeof(char*);
  879. X        if (len > along)
  880. X        len = along;
  881. X        while (len-- > 0) {
  882. X        if (sizeof(char*) > strend - s)
  883. X            break;
  884. X        else {
  885. X            bcopy(s,(char*)&aptr,sizeof(char*));
  886. X            s += sizeof(char*);
  887. X        }
  888. X        str = Str_new(44,0);
  889. X        if (aptr)
  890. X            str_set(str,aptr);
  891. X        (void)astore(stack, ++sp, str_2mortal(str));
  892. X        }
  893. X        break;
  894. X    /* float and double added gnb@melba.bby.oz.au 22/11/89 */
  895. X    case 'f':
  896. X    case 'F':
  897. X        along = (strend - s) / sizeof(float);
  898. X        if (len > along)
  899. X        len = along;
  900. X        if (checksum) {
  901. X        while (len-- > 0) {
  902. X            bcopy(s, (char *)&afloat, sizeof(float));
  903. X            s += sizeof(float);
  904. X            cdouble += afloat;
  905. X        }
  906. X        }
  907. X        else {
  908. X        while (len-- > 0) {
  909. X            bcopy(s, (char *)&afloat, sizeof(float));
  910. X            s += sizeof(float);
  911. X            str = Str_new(47, 0);
  912. X            str_numset(str, (double)afloat);
  913. X            (void)astore(stack, ++sp, str_2mortal(str));
  914. X        }
  915. X        }
  916. X        break;
  917. X    case 'd':
  918. X    case 'D':
  919. X        along = (strend - s) / sizeof(double);
  920. X        if (len > along)
  921. X        len = along;
  922. X        if (checksum) {
  923. X        while (len-- > 0) {
  924. X            bcopy(s, (char *)&adouble, sizeof(double));
  925. X            s += sizeof(double);
  926. X            cdouble += adouble;
  927. X        }
  928. X        }
  929. X        else {
  930. X        while (len-- > 0) {
  931. X            bcopy(s, (char *)&adouble, sizeof(double));
  932. X            s += sizeof(double);
  933. X            str = Str_new(48, 0);
  934. X            str_numset(str, (double)adouble);
  935. X            (void)astore(stack, ++sp, str_2mortal(str));
  936. X        }
  937. X        }
  938. X        break;
  939. X    case 'u':
  940. X        along = (strend - s) * 3 / 4;
  941. X        str = Str_new(42,along);
  942. X        while (s < strend && *s > ' ' && *s < 'a') {
  943. X        int a,b,c,d;
  944. X        char hunk[4];
  945. X
  946. X        hunk[3] = '\0';
  947. X        len = (*s++ - ' ') & 077;
  948. X        while (len > 0) {
  949. X            if (s < strend && *s >= ' ')
  950. X            a = (*s++ - ' ') & 077;
  951. X            else
  952. X            a = 0;
  953. X            if (s < strend && *s >= ' ')
  954. X            b = (*s++ - ' ') & 077;
  955. X            else
  956. X            b = 0;
  957. X            if (s < strend && *s >= ' ')
  958. X            c = (*s++ - ' ') & 077;
  959. X            else
  960. X            c = 0;
  961. X            if (s < strend && *s >= ' ')
  962. X            d = (*s++ - ' ') & 077;
  963. X            else
  964. X            d = 0;
  965. X            hunk[0] = a << 2 | b >> 4;
  966. X            hunk[1] = b << 4 | c >> 2;
  967. X            hunk[2] = c << 6 | d;
  968. X            str_ncat(str,hunk, len > 3 ? 3 : len);
  969. X            len -= 3;
  970. X        }
  971. X        if (*s == '\n')
  972. X            s++;
  973. X        else if (s[1] == '\n')        /* possible checksum byte */
  974. X            s += 2;
  975. X        }
  976. X        (void)astore(stack, ++sp, str_2mortal(str));
  977. X        break;
  978. X    }
  979. X    if (checksum) {
  980. X        str = Str_new(42,0);
  981. X        if (index("fFdD", datumtype) ||
  982. X          (checksum > 32 && index("iIlLN", datumtype)) ) {
  983. X        double modf();
  984. X        double trouble;
  985. X
  986. X        adouble = 1.0;
  987. X        while (checksum >= 16) {
  988. X            checksum -= 16;
  989. X            adouble *= 65536.0;
  990. X        }
  991. X        while (checksum >= 4) {
  992. X            checksum -= 4;
  993. X            adouble *= 16.0;
  994. X        }
  995. X        while (checksum--)
  996. X            adouble *= 2.0;
  997. X        along = (1 << checksum) - 1;
  998. X        while (cdouble < 0.0)
  999. X            cdouble += adouble;
  1000. X        cdouble = modf(cdouble / adouble, &trouble) * adouble;
  1001. X        str_numset(str,cdouble);
  1002. X        }
  1003. X        else {
  1004. X        if (checksum < 32) {
  1005. X            along = (1 << checksum) - 1;
  1006. X            culong &= (unsigned long)along;
  1007. X        }
  1008. X        str_numset(str,(double)culong);
  1009. X        }
  1010. X        (void)astore(stack, ++sp, str_2mortal(str));
  1011. X        checksum = 0;
  1012. X    }
  1013. X    }
  1014. X    return sp;
  1015. X}
  1016. X
  1017. Xint
  1018. Xdo_slice(stab,str,numarray,lval,gimme,arglast)
  1019. XSTAB *stab;
  1020. XSTR *str;
  1021. Xint numarray;
  1022. Xint lval;
  1023. Xint gimme;
  1024. Xint *arglast;
  1025. X{
  1026. X    register STR **st = stack->ary_array;
  1027. X    register int sp = arglast[1];
  1028. X    register int max = arglast[2];
  1029. X    register char *tmps;
  1030. X    register int len;
  1031. X    register int magic = 0;
  1032. X    register ARRAY *ary;
  1033. X    register HASH *hash;
  1034. X    int oldarybase = arybase;
  1035. X
  1036. X    if (numarray) {
  1037. X    if (numarray == 2) {        /* a slice of a LIST */
  1038. X        ary = stack;
  1039. X        ary->ary_fill = arglast[3];
  1040. X        arybase -= max + 1;
  1041. X        st[sp] = str;        /* make stack size available */
  1042. X        str_numset(str,(double)(sp - 1));
  1043. X    }
  1044. X    else
  1045. X        ary = stab_array(stab);    /* a slice of an array */
  1046. X    }
  1047. X    else {
  1048. X    if (lval) {
  1049. X        if (stab == envstab)
  1050. X        magic = 'E';
  1051. X        else if (stab == sigstab)
  1052. X        magic = 'S';
  1053. X#ifdef SOME_DBM
  1054. X        else if (stab_hash(stab)->tbl_dbm)
  1055. X        magic = 'D';
  1056. X#endif /* SOME_DBM */
  1057. X    }
  1058. X    hash = stab_hash(stab);        /* a slice of an associative array */
  1059. X    }
  1060. X
  1061. X    if (gimme == G_ARRAY) {
  1062. X    if (numarray) {
  1063. X        while (sp < max) {
  1064. X        if (st[++sp]) {
  1065. X            st[sp-1] = afetch(ary,
  1066. X              ((int)str_gnum(st[sp])) - arybase, lval);
  1067. X        }
  1068. X        else
  1069. X            st[sp-1] = &str_undef;
  1070. X        }
  1071. X    }
  1072. X    else {
  1073. X        while (sp < max) {
  1074. X        if (st[++sp]) {
  1075. X            tmps = str_get(st[sp]);
  1076. X            len = st[sp]->str_cur;
  1077. X            st[sp-1] = hfetch(hash,tmps,len, lval);
  1078. X            if (magic)
  1079. X            str_magic(st[sp-1],stab,magic,tmps,len);
  1080. X        }
  1081. X        else
  1082. X            st[sp-1] = &str_undef;
  1083. X        }
  1084. X    }
  1085. X    sp--;
  1086. X    }
  1087. X    else {
  1088. X    if (numarray) {
  1089. X        if (st[max])
  1090. X        st[sp] = afetch(ary,
  1091. X          ((int)str_gnum(st[max])) - arybase, lval);
  1092. X        else
  1093. X        st[sp] = &str_undef;
  1094. X    }
  1095. X    else {
  1096. X        if (st[max]) {
  1097. X        tmps = str_get(st[max]);
  1098. X        len = st[max]->str_cur;
  1099. X        st[sp] = hfetch(hash,tmps,len, lval);
  1100. X        if (magic)
  1101. X            str_magic(st[sp],stab,magic,tmps,len);
  1102. X        }
  1103. X        else
  1104. X        st[sp] = &str_undef;
  1105. X    }
  1106. X    }
  1107. X    arybase = oldarybase;
  1108. X    return sp;
  1109. X}
  1110. X
  1111. Xint
  1112. Xdo_splice(ary,gimme,arglast)
  1113. Xregister ARRAY *ary;
  1114. Xint gimme;
  1115. Xint *arglast;
  1116. X{
  1117. X    register STR **st = stack->ary_array;
  1118. X    register int sp = arglast[1];
  1119. X    int max = arglast[2] + 1;
  1120. X    register STR **src;
  1121. X    register STR **dst;
  1122. X    register int i;
  1123. X    register int offset;
  1124. X    register int length;
  1125. X    int newlen;
  1126. X    int after;
  1127. X    int diff;
  1128. X    STR **tmparyval;
  1129. X
  1130. X    if (++sp < max) {
  1131. X    offset = ((int)str_gnum(st[sp])) - arybase;
  1132. X    if (offset < 0)
  1133. X        offset += ary->ary_fill + 1;
  1134. X    if (++sp < max) {
  1135. X        length = (int)str_gnum(st[sp++]);
  1136. X        if (length < 0)
  1137. X        length = 0;
  1138. X    }
  1139. X    else
  1140. X        length = ary->ary_max;        /* close enough to infinity */
  1141. X    }
  1142. X    else {
  1143. X    offset = 0;
  1144. X    length = ary->ary_max;
  1145. X    }
  1146. X    if (offset < 0) {
  1147. X    length += offset;
  1148. X    offset = 0;
  1149. X    if (length < 0)
  1150. X        length = 0;
  1151. X    }
  1152. X    if (offset > ary->ary_fill + 1)
  1153. X    offset = ary->ary_fill + 1;
  1154. X    after = ary->ary_fill + 1 - (offset + length);
  1155. X    if (after < 0) {                /* not that much array */
  1156. X    length += after;            /* offset+length now in array */
  1157. X    after = 0;
  1158. X    if (!ary->ary_alloc) {
  1159. X        afill(ary,0);
  1160. X        afill(ary,-1);
  1161. X    }
  1162. X    }
  1163. X
  1164. X    /* At this point, sp .. max-1 is our new LIST */
  1165. X
  1166. X    newlen = max - sp;
  1167. X    diff = newlen - length;
  1168. X
  1169. X    if (diff < 0) {                /* shrinking the area */
  1170. X    if (newlen) {
  1171. X        New(451, tmparyval, newlen, STR*);    /* so remember insertion */
  1172. X        Copy(st+sp, tmparyval, newlen, STR*);
  1173. X    }
  1174. X
  1175. X    sp = arglast[0] + 1;
  1176. X    if (gimme == G_ARRAY) {            /* copy return vals to stack */
  1177. X        if (sp + length >= stack->ary_max) {
  1178. X        astore(stack,sp + length, Nullstr);
  1179. X        st = stack->ary_array;
  1180. X        }
  1181. X        Copy(ary->ary_array+offset, st+sp, length, STR*);
  1182. X        if (ary->ary_flags & ARF_REAL) {
  1183. X        for (i = length, dst = st+sp; i; i--)
  1184. X            str_2mortal(*dst++);    /* free them eventualy */
  1185. X        }
  1186. X        sp += length - 1;
  1187. X    }
  1188. X    else {
  1189. X        st[sp] = ary->ary_array[offset+length-1];
  1190. X        if (ary->ary_flags & ARF_REAL)
  1191. X        str_2mortal(st[sp]);
  1192. X    }
  1193. X    ary->ary_fill += diff;
  1194. X
  1195. X    /* pull up or down? */
  1196. X
  1197. X    if (offset < after) {            /* easier to pull up */
  1198. X        if (offset) {            /* esp. if nothing to pull */
  1199. X        src = &ary->ary_array[offset-1];
  1200. X        dst = src - diff;        /* diff is negative */
  1201. X        for (i = offset; i > 0; i--)    /* can't trust Copy */
  1202. X            *dst-- = *src--;
  1203. X        }
  1204. X        Zero(ary->ary_array, -diff, STR*);
  1205. X        ary->ary_array -= diff;        /* diff is negative */
  1206. X        ary->ary_max += diff;
  1207. X    }
  1208. X    else {
  1209. X        if (after) {            /* anything to pull down? */
  1210. X        src = ary->ary_array + offset + length;
  1211. X        dst = src + diff;        /* diff is negative */
  1212. X        Copy(src, dst, after, STR*);
  1213. X        }
  1214. X        Zero(&ary->ary_array[ary->ary_fill+1], -diff, STR*);
  1215. X                        /* avoid later double free */
  1216. X    }
  1217. X    if (newlen) {
  1218. X        for (src = tmparyval, dst = ary->ary_array + offset;
  1219. X          newlen; newlen--) {
  1220. X        *dst = Str_new(46,0);
  1221. X        str_sset(*dst++,*src++);
  1222. X        }
  1223. X        Safefree(tmparyval);
  1224. X    }
  1225. X    }
  1226. X    else {                    /* no, expanding (or same) */
  1227. X    if (length) {
  1228. X        New(452, tmparyval, length, STR*);    /* so remember deletion */
  1229. X        Copy(ary->ary_array+offset, tmparyval, length, STR*);
  1230. X    }
  1231. X
  1232. X    if (diff > 0) {                /* expanding */
  1233. X
  1234. X        /* push up or down? */
  1235. X
  1236. X        if (offset < after && diff <= ary->ary_array - ary->ary_alloc) {
  1237. X        if (offset) {
  1238. X            src = ary->ary_array;
  1239. X            dst = src - diff;
  1240. X            Copy(src, dst, offset, STR*);
  1241. X        }
  1242. X        ary->ary_array -= diff;        /* diff is positive */
  1243. X        ary->ary_max += diff;
  1244. X        ary->ary_fill += diff;
  1245. X        }
  1246. X        else {
  1247. X        if (ary->ary_fill + diff >= ary->ary_max)    /* oh, well */
  1248. X            astore(ary, ary->ary_fill + diff, Nullstr);
  1249. X        else
  1250. X            ary->ary_fill += diff;
  1251. X        if (after) {
  1252. X            dst = ary->ary_array + ary->ary_fill;
  1253. X            src = dst - diff;
  1254. X            for (i = after; i; i--) {
  1255. X            if (*dst)        /* str was hanging around */
  1256. X                str_free(*dst);    /*  after $#foo */
  1257. X            *dst-- = *src;
  1258. X            *src-- = Nullstr;
  1259. X            }
  1260. X        }
  1261. X        }
  1262. X    }
  1263. X
  1264. X    for (src = st+sp, dst = ary->ary_array + offset; newlen; newlen--) {
  1265. X        *dst = Str_new(46,0);
  1266. X        str_sset(*dst++,*src++);
  1267. X    }
  1268. X    sp = arglast[0] + 1;
  1269. X    if (gimme == G_ARRAY) {            /* copy return vals to stack */
  1270. X        if (length) {
  1271. X        Copy(tmparyval, st+sp, length, STR*);
  1272. X        if (ary->ary_flags & ARF_REAL) {
  1273. X            for (i = length, dst = st+sp; i; i--)
  1274. X            str_2mortal(*dst++);    /* free them eventualy */
  1275. X        }
  1276. X        Safefree(tmparyval);
  1277. X        }
  1278. X        sp += length - 1;
  1279. X    }
  1280. X    else if (length) {
  1281. X        st[sp] = tmparyval[length-1];
  1282. X        if (ary->ary_flags & ARF_REAL)
  1283. X        str_2mortal(st[sp]);
  1284. X        Safefree(tmparyval);
  1285. X    }
  1286. X    else
  1287. X        st[sp] = &str_undef;
  1288. X    }
  1289. X    return sp;
  1290. X}
  1291. X
  1292. Xint
  1293. Xdo_grep(arg,str,gimme,arglast)
  1294. Xregister ARG *arg;
  1295. XSTR *str;
  1296. Xint gimme;
  1297. Xint *arglast;
  1298. X{
  1299. X    STR **st = stack->ary_array;
  1300. X    register int dst = arglast[1];
  1301. X    register int src = dst + 1;
  1302. X    register int sp = arglast[2];
  1303. X    register int i = sp - arglast[1];
  1304. X    int oldsave = savestack->ary_fill;
  1305. X    SPAT *oldspat = curspat;
  1306. X    int oldtmps_base = tmps_base;
  1307. X
  1308. X    savesptr(&stab_val(defstab));
  1309. X    tmps_base = tmps_max;
  1310. X    if ((arg[1].arg_type & A_MASK) != A_EXPR) {
  1311. X    arg[1].arg_type &= A_MASK;
  1312. X    dehoist(arg,1);
  1313. X    arg[1].arg_type |= A_DONT;
  1314. X    }
  1315. X    arg = arg[1].arg_ptr.arg_arg;
  1316. X    while (i-- > 0) {
  1317. X    if (st[src])
  1318. X        stab_val(defstab) = st[src];
  1319. X    else
  1320. X        stab_val(defstab) = str_mortal(&str_undef);
  1321. X    (void)eval(arg,G_SCALAR,sp);
  1322. X    st = stack->ary_array;
  1323. X    if (str_true(st[sp+1]))
  1324. X        st[dst++] = st[src];
  1325. X    src++;
  1326. X    curspat = oldspat;
  1327. X    }
  1328. X    restorelist(oldsave);
  1329. X    tmps_base = oldtmps_base;
  1330. X    if (gimme != G_ARRAY) {
  1331. X    str_numset(str,(double)(dst - arglast[1]));
  1332. X    STABSET(str);
  1333. X    st[arglast[0]+1] = str;
  1334. X    return arglast[0]+1;
  1335. X    }
  1336. X    return arglast[0] + (dst - arglast[1]);
  1337. X}
  1338. X
  1339. Xint
  1340. Xdo_reverse(arglast)
  1341. Xint *arglast;
  1342. X{
  1343. X    STR **st = stack->ary_array;
  1344. X    register STR **up = &st[arglast[1]];
  1345. X    register STR **down = &st[arglast[2]];
  1346. X    register int i = arglast[2] - arglast[1];
  1347. X
  1348. X    while (i-- > 0) {
  1349. X    *up++ = *down;
  1350. X    if (i-- > 0)
  1351. X        *down-- = *up;
  1352. X    }
  1353. X    i = arglast[2] - arglast[1];
  1354. X    Copy(down+1,up,i/2,STR*);
  1355. X    return arglast[2] - 1;
  1356. X}
  1357. X
  1358. Xint
  1359. Xdo_sreverse(str,arglast)
  1360. XSTR *str;
  1361. Xint *arglast;
  1362. X{
  1363. X    STR **st = stack->ary_array;
  1364. X    register char *up;
  1365. X    register char *down;
  1366. X    register int tmp;
  1367. X
  1368. X    str_sset(str,st[arglast[2]]);
  1369. X    up = str_get(str);
  1370. X    if (str->str_cur > 1) {
  1371. X    down = str->str_ptr + str->str_cur - 1;
  1372. X    while (down > up) {
  1373. X        tmp = *up;
  1374. X        *up++ = *down;
  1375. X        *down-- = tmp;
  1376. X    }
  1377. X    }
  1378. X    STABSET(str);
  1379. X    st[arglast[0]+1] = str;
  1380. X    return arglast[0]+1;
  1381. X}
  1382. X
  1383. Xstatic CMD *sortcmd;
  1384. Xstatic HASH *sortstash = Null(HASH*);
  1385. Xstatic STAB *firststab = Nullstab;
  1386. Xstatic STAB *secondstab = Nullstab;
  1387. X
  1388. Xint
  1389. Xdo_sort(str,stab,gimme,arglast)
  1390. XSTR *str;
  1391. XSTAB *stab;
  1392. Xint gimme;
  1393. Xint *arglast;
  1394. X{
  1395. X    register STR **st = stack->ary_array;
  1396. X    int sp = arglast[1];
  1397. X    register STR **up;
  1398. X    register int max = arglast[2] - sp;
  1399. X    register int i;
  1400. X    int sortcmp();
  1401. X    int sortsub();
  1402. X    STR *oldfirst;
  1403. X    STR *oldsecond;
  1404. X    ARRAY *oldstack;
  1405. X    static ARRAY *sortstack = Null(ARRAY*);
  1406. X
  1407. X    if (gimme != G_ARRAY) {
  1408. X    str_sset(str,&str_undef);
  1409. X    STABSET(str);
  1410. X    st[sp] = str;
  1411. X    return sp;
  1412. X    }
  1413. X    up = &st[sp];
  1414. X    st += sp;        /* temporarily make st point to args */
  1415. X    for (i = 1; i <= max; i++) {
  1416. X    if (*up = st[i]) {
  1417. X        if (!(*up)->str_pok)
  1418. X        (void)str_2ptr(*up);
  1419. X        else
  1420. X        (*up)->str_pok &= ~SP_TEMP;
  1421. X        up++;
  1422. X    }
  1423. X    }
  1424. X    st -= sp;
  1425. X    max = up - &st[sp];
  1426. X    sp--;
  1427. X    if (max > 1) {
  1428. X    if (stab) {
  1429. X        int oldtmps_base = tmps_base;
  1430. X
  1431. X        if (!stab_sub(stab) || !(sortcmd = stab_sub(stab)->cmd))
  1432. X        fatal("Undefined subroutine \"%s\" in sort", stab_name(stab));
  1433. X        if (!sortstack) {
  1434. X        sortstack = anew(Nullstab);
  1435. X        astore(sortstack, 0, Nullstr);
  1436. X        aclear(sortstack);
  1437. X        sortstack->ary_flags = 0;
  1438. X        }
  1439. X        oldstack = stack;
  1440. X        stack = sortstack;
  1441. X        tmps_base = tmps_max;
  1442. X        if (sortstash != stab_stash(stab)) {
  1443. X        firststab = stabent("a",TRUE);
  1444. X        secondstab = stabent("b",TRUE);
  1445. X        sortstash = stab_stash(stab);
  1446. X        }
  1447. X        oldfirst = stab_val(firststab);
  1448. X        oldsecond = stab_val(secondstab);
  1449. X#ifndef lint
  1450. X        qsort((char*)(st+sp+1),max,sizeof(STR*),sortsub);
  1451. X#else
  1452. X        qsort(Nullch,max,sizeof(STR*),sortsub);
  1453. X#endif
  1454. X        stab_val(firststab) = oldfirst;
  1455. X        stab_val(secondstab) = oldsecond;
  1456. X        tmps_base = oldtmps_base;
  1457. X        stack = oldstack;
  1458. X    }
  1459. X#ifndef lint
  1460. X    else
  1461. X        qsort((char*)(st+sp+1),max,sizeof(STR*),sortcmp);
  1462. X#endif
  1463. X    }
  1464. X    return sp+max;
  1465. X}
  1466. X
  1467. Xint
  1468. Xsortsub(str1,str2)
  1469. XSTR **str1;
  1470. XSTR **str2;
  1471. X{
  1472. X    stab_val(firststab) = *str1;
  1473. X    stab_val(secondstab) = *str2;
  1474. X    cmd_exec(sortcmd,G_SCALAR,-1);
  1475. X    return (int)str_gnum(*stack->ary_array);
  1476. X}
  1477. X
  1478. Xsortcmp(strp1,strp2)
  1479. XSTR **strp1;
  1480. XSTR **strp2;
  1481. X{
  1482. X    register STR *str1 = *strp1;
  1483. X    register STR *str2 = *strp2;
  1484. X    int retval;
  1485. X
  1486. X    if (str1->str_cur < str2->str_cur) {
  1487. X    if (retval = memcmp(str1->str_ptr, str2->str_ptr, str1->str_cur))
  1488. X        return retval;
  1489. X    else
  1490. X        return -1;
  1491. X    }
  1492. X    else if (retval = memcmp(str1->str_ptr, str2->str_ptr, str2->str_cur))
  1493. X    return retval;
  1494. X    else if (str1->str_cur == str2->str_cur)
  1495. X    return 0;
  1496. X    else
  1497. X    return 1;
  1498. X}
  1499. X
  1500. Xint
  1501. Xdo_range(gimme,arglast)
  1502. Xint gimme;
  1503. Xint *arglast;
  1504. X{
  1505. X    STR **st = stack->ary_array;
  1506. X    register int sp = arglast[0];
  1507. X    register int i;
  1508. X    register ARRAY *ary = stack;
  1509. X    register STR *str;
  1510. X    int max;
  1511. X
  1512. X    if (gimme != G_ARRAY)
  1513. X    fatal("panic: do_range");
  1514. X
  1515. X    if (st[sp+1]->str_nok || !st[sp+1]->str_pok ||
  1516. X      (looks_like_number(st[sp+1]) && *st[sp+1]->str_ptr != '0') ) {
  1517. X    i = (int)str_gnum(st[sp+1]);
  1518. X    max = (int)str_gnum(st[sp+2]);
  1519. X    while (i <= max) {
  1520. X        (void)astore(ary, ++sp, str = str_mortal(&str_no));
  1521. X        str_numset(str,(double)i++);
  1522. X    }
  1523. X    }
  1524. X    else {
  1525. X    STR *final = str_mortal(st[sp+2]);
  1526. X    char *tmps = str_get(final);
  1527. X
  1528. X    str = str_mortal(st[sp+1]);
  1529. X    while (!str->str_nok && str->str_cur <= final->str_cur &&
  1530. X        strNE(str->str_ptr,tmps) ) {
  1531. X        (void)astore(ary, ++sp, str);
  1532. X        str = str_2mortal(str_smake(str));
  1533. X        str_inc(str);
  1534. X    }
  1535. X    if (strEQ(str->str_ptr,tmps))
  1536. X        (void)astore(ary, ++sp, str);
  1537. X    }
  1538. X    return sp;
  1539. X}
  1540. X
  1541. Xint
  1542. Xdo_repeatary(arglast)
  1543. Xint *arglast;
  1544. X{
  1545. X    STR **st = stack->ary_array;
  1546. X    register int sp = arglast[0];
  1547. X    register int items = arglast[1] - sp;
  1548. X    register int count = (int) str_gnum(st[arglast[2]]);
  1549. X    register ARRAY *ary = stack;
  1550. X    register int i;
  1551. X    int max;
  1552. X
  1553. X    max = items * count;
  1554. X    if (max > 0 && sp + max > stack->ary_max) {
  1555. X    astore(stack, sp + max, Nullstr);
  1556. X    st = stack->ary_array;
  1557. X    }
  1558. X    if (count > 1) {
  1559. X    for (i = arglast[1]; i > sp; i--)
  1560. X        st[i]->str_pok &= ~SP_TEMP;
  1561. X    repeatcpy((char*)&st[arglast[1]+1], (char*)&st[sp+1],
  1562. X        items * sizeof(STR*), count);
  1563. X    }
  1564. X    sp += max;
  1565. X
  1566. X    return sp;
  1567. X}
  1568. X
  1569. Xint
  1570. Xdo_caller(arg,maxarg,gimme,arglast)
  1571. XARG *arg;
  1572. Xint maxarg;
  1573. Xint gimme;
  1574. Xint *arglast;
  1575. X{
  1576. X    STR **st = stack->ary_array;
  1577. X    register int sp = arglast[0];
  1578. X    register CSV *csv = curcsv;
  1579. X    STR *str;
  1580. X    int count = 0;
  1581. X
  1582. X    if (!csv)
  1583. X    fatal("There is no caller");
  1584. X    if (maxarg)
  1585. X    count = (int) str_gnum(st[sp+1]);
  1586. X    for (;;) {
  1587. X    if (!csv)
  1588. X        return sp;
  1589. X    if (DBsub && csv->curcsv && csv->curcsv->sub == stab_sub(DBsub))
  1590. X        count++;
  1591. X    if (!count--)
  1592. X        break;
  1593. X    csv = csv->curcsv;
  1594. X    }
  1595. X    if (gimme != G_ARRAY) {
  1596. X    STR *str = arg->arg_ptr.arg_str;
  1597. X    str_set(str,csv->curcmd->c_stash->tbl_name);
  1598. X    STABSET(str);
  1599. X    st[++sp] = str;
  1600. X    return sp;
  1601. X    }
  1602. X
  1603. X#ifndef lint
  1604. X    (void)astore(stack,++sp,
  1605. X      str_2mortal(str_make(csv->curcmd->c_stash->tbl_name,0)) );
  1606. X    (void)astore(stack,++sp,
  1607. X      str_2mortal(str_make(stab_val(csv->curcmd->c_filestab)->str_ptr,0)) );
  1608. X    (void)astore(stack,++sp,
  1609. X      str_2mortal(str_nmake((double)csv->curcmd->c_line)) );
  1610. X    if (!maxarg)
  1611. X    return sp;
  1612. X    str = Str_new(49,0);
  1613. X    stab_fullname(str, csv->stab);
  1614. X    (void)astore(stack,++sp, str_2mortal(str));
  1615. X    (void)astore(stack,++sp,
  1616. X      str_2mortal(str_nmake((double)csv->hasargs)) );
  1617. X    (void)astore(stack,++sp,
  1618. X      str_2mortal(str_nmake((double)csv->wantarray)) );
  1619. X    if (csv->hasargs) {
  1620. X    ARRAY *ary = csv->argarray;
  1621. X
  1622. X    if (dbargs->ary_max < ary->ary_fill)
  1623. X        astore(dbargs,ary->ary_fill,Nullstr);
  1624. X    Copy(ary->ary_array, dbargs->ary_array, ary->ary_fill+1, STR*);
  1625. X    dbargs->ary_fill = ary->ary_fill;
  1626. X    }
  1627. X#else
  1628. X    (void)astore(stack,++sp,
  1629. X      str_2mortal(str_make("",0)));
  1630. X#endif
  1631. X    return sp;
  1632. X}
  1633. X
  1634. Xint
  1635. Xdo_tms(str,gimme,arglast)
  1636. XSTR *str;
  1637. Xint gimme;
  1638. Xint *arglast;
  1639. X{
  1640. X#ifdef MSDOS
  1641. X    return -1;
  1642. X#else
  1643. X    STR **st = stack->ary_array;
  1644. X    register int sp = arglast[0];
  1645. X
  1646. X    if (gimme != G_ARRAY) {
  1647. X    str_sset(str,&str_undef);
  1648. X    STABSET(str);
  1649. X    st[++sp] = str;
  1650. X    return sp;
  1651. X    }
  1652. X    (void)times(×buf);
  1653. X
  1654. X#ifndef HZ
  1655. X#define HZ 60
  1656. X#endif
  1657. X
  1658. X#ifndef lint
  1659. X    (void)astore(stack,++sp,
  1660. X      str_2mortal(str_nmake(((double)timesbuf.tms_utime)/HZ)));
  1661. X    (void)astore(stack,++sp,
  1662. X      str_2mortal(str_nmake(((double)timesbuf.tms_stime)/HZ)));
  1663. X    (void)astore(stack,++sp,
  1664. X      str_2mortal(str_nmake(((double)timesbuf.tms_cutime)/HZ)));
  1665. X    (void)astore(stack,++sp,
  1666. X      str_2mortal(str_nmake(((double)timesbuf.tms_cstime)/HZ)));
  1667. X#else
  1668. X    (void)astore(stack,++sp,
  1669. X      str_2mortal(str_nmake(0.0)));
  1670. X#endif
  1671. X    return sp;
  1672. X#endif
  1673. X}
  1674. X
  1675. Xint
  1676. Xdo_time(str,tmbuf,gimme,arglast)
  1677. XSTR *str;
  1678. Xstruct tm *tmbuf;
  1679. Xint gimme;
  1680. Xint *arglast;
  1681. X{
  1682. X    register ARRAY *ary = stack;
  1683. X    STR **st = ary->ary_array;
  1684. X    register int sp = arglast[0];
  1685. X
  1686. X    if (!tmbuf || gimme != G_ARRAY) {
  1687. X    str_sset(str,&str_undef);
  1688. X    STABSET(str);
  1689. X    st[++sp] = str;
  1690. X    return sp;
  1691. X    }
  1692. X    (void)astore(ary,++sp,str_2mortal(str_nmake((double)tmbuf->tm_sec)));
  1693. X    (void)astore(ary,++sp,str_2mortal(str_nmake((double)tmbuf->tm_min)));
  1694. X    (void)astore(ary,++sp,str_2mortal(str_nmake((double)tmbuf->tm_hour)));
  1695. X    (void)astore(ary,++sp,str_2mortal(str_nmake((double)tmbuf->tm_mday)));
  1696. X    (void)astore(ary,++sp,str_2mortal(str_nmake((double)tmbuf->tm_mon)));
  1697. X    (void)astore(ary,++sp,str_2mortal(str_nmake((double)tmbuf->tm_year)));
  1698. X    (void)astore(ary,++sp,str_2mortal(str_nmake((double)tmbuf->tm_wday)));
  1699. X    (void)astore(ary,++sp,str_2mortal(str_nmake((double)tmbuf->tm_yday)));
  1700. X    (void)astore(ary,++sp,str_2mortal(str_nmake((double)tmbuf->tm_isdst)));
  1701. X    return sp;
  1702. X}
  1703. X
  1704. Xint
  1705. Xdo_kv(str,hash,kv,gimme,arglast)
  1706. XSTR *str;
  1707. XHASH *hash;
  1708. Xint kv;
  1709. Xint gimme;
  1710. Xint *arglast;
  1711. X{
  1712. X    register ARRAY *ary = stack;
  1713. X    STR **st = ary->ary_array;
  1714. X    register int sp = arglast[0];
  1715. X    int i;
  1716. X    register HENT *entry;
  1717. X    char *tmps;
  1718. X    STR *tmpstr;
  1719. X    int dokeys = (kv == O_KEYS || kv == O_HASH);
  1720. X    int dovalues = (kv == O_VALUES || kv == O_HASH);
  1721. X
  1722. X    if (gimme != G_ARRAY) {
  1723. X    str_sset(str,&str_undef);
  1724. X    STABSET(str);
  1725. X    st[++sp] = str;
  1726. X    return sp;
  1727. X    }
  1728. X    (void)hiterinit(hash);
  1729. X    while (entry = hiternext(hash)) {
  1730. X    if (dokeys) {
  1731. X        tmps = hiterkey(entry,&i);
  1732. X        if (!i)
  1733. X        tmps = "";
  1734. X        (void)astore(ary,++sp,str_2mortal(str_make(tmps,i)));
  1735. X    }
  1736. X    if (dovalues) {
  1737. X        tmpstr = Str_new(45,0);
  1738. X#ifdef DEBUGGING
  1739. X        if (debug & 8192) {
  1740. X        sprintf(buf,"%d%%%d=%d\n",entry->hent_hash,
  1741. X            hash->tbl_max+1,entry->hent_hash & hash->tbl_max);
  1742. X        str_set(tmpstr,buf);
  1743. X        }
  1744. X        else
  1745. X#endif
  1746. X        str_sset(tmpstr,hiterval(hash,entry));
  1747. X        (void)astore(ary,++sp,str_2mortal(tmpstr));
  1748. X    }
  1749. X    }
  1750. X    return sp;
  1751. X}
  1752. X
  1753. Xint
  1754. Xdo_each(str,hash,gimme,arglast)
  1755. XSTR *str;
  1756. XHASH *hash;
  1757. Xint gimme;
  1758. Xint *arglast;
  1759. X{
  1760. X    STR **st = stack->ary_array;
  1761. X    register int sp = arglast[0];
  1762. X    static STR *mystrk = Nullstr;
  1763. X    HENT *entry = hiternext(hash);
  1764. X    int i;
  1765. X    char *tmps;
  1766. X
  1767. X    if (mystrk) {
  1768. X    str_free(mystrk);
  1769. X    mystrk = Nullstr;
  1770. X    }
  1771. X
  1772. X    if (entry) {
  1773. X    if (gimme == G_ARRAY) {
  1774. X        tmps = hiterkey(entry, &i);
  1775. X        if (!i)
  1776. X        tmps = "";
  1777. X        st[++sp] = mystrk = str_make(tmps,i);
  1778. X    }
  1779. X    st[++sp] = str;
  1780. X    str_sset(str,hiterval(hash,entry));
  1781. X    STABSET(str);
  1782. X    return sp;
  1783. X    }
  1784. X    else
  1785. X    return sp;
  1786. X}
  1787. !STUFFY!FUNK!
  1788. echo Extracting h2ph.SH
  1789. sed >h2ph.SH <<'!STUFFY!FUNK!' -e 's/X//'
  1790. Xcase $CONFIG in
  1791. X'')
  1792. X    if test ! -f config.sh; then
  1793. X    ln ../config.sh . || \
  1794. X    ln ../../config.sh . || \
  1795. X    ln ../../../config.sh . || \
  1796. X    (echo "Can't find config.sh."; exit 1)
  1797. X    fi 2>/dev/null
  1798. X    . ./config.sh
  1799. X    ;;
  1800. Xesac
  1801. X: This forces SH files to create target in same directory as SH file.
  1802. X: This is so that make depend always knows where to find SH derivatives.
  1803. Xcase "$0" in
  1804. X*/*) cd `expr X$0 : 'X\(.*\)/'` ;;
  1805. Xesac
  1806. Xecho "Extracting h2ph (with variable substitutions)"
  1807. X: This section of the file will have variable substitutions done on it.
  1808. X: Move anything that needs config subs from !NO!SUBS! section to !GROK!THIS!.
  1809. X: Protect any dollar signs and backticks that you do not want interpreted
  1810. X: by putting a backslash in front.  You may delete these comments.
  1811. X$spitshell >h2ph <<!GROK!THIS!
  1812. X#!$bin/perl
  1813. X'di';
  1814. X'ig00';
  1815. X
  1816. X\$perlincl = '$privlib';
  1817. X!GROK!THIS!
  1818. X
  1819. X: In the following dollars and backticks do not need the extra backslash.
  1820. X$spitshell >>h2ph <<'!NO!SUBS!'
  1821. X
  1822. Xchdir '/usr/include' || die "Can't cd /usr/include";
  1823. X
  1824. X@isatype = split(' ',<<END);
  1825. X    char    uchar    u_char
  1826. X    short    ushort    u_short
  1827. X    int    uint    u_int
  1828. X    long    ulong    u_long
  1829. X    FILE
  1830. XEND
  1831. X
  1832. X$isatype{@isatype} = (1) x @isatype;
  1833. X
  1834. X@ARGV = ('-') unless @ARGV;
  1835. X
  1836. Xforeach $file (@ARGV) {
  1837. X    if ($file eq '-') {
  1838. X    open(IN, "-");
  1839. X    open(OUT, ">-");
  1840. X    }
  1841. X    else {
  1842. X    ($outfile = $file) =~ s/\.h$/.ph/ || next;
  1843. X    print "$file -> $outfile\n";
  1844. X    if ($file =~ m|^(.*)/|) {
  1845. X        $dir = $1;
  1846. X        if (!-d "$perlincl/$dir") {
  1847. X        mkdir("$perlincl/$dir",0777);
  1848. X        }
  1849. X    }
  1850. X    open(IN,"$file") || ((warn "Can't open $file: $!\n"),next);
  1851. X    open(OUT,">$perlincl/$outfile") || die "Can't create $outfile: $!\n";
  1852. X    }
  1853. X    while (<IN>) {
  1854. X    chop;
  1855. X    while (/\\$/) {
  1856. X        chop;
  1857. X        $_ .= <IN>;
  1858. X        chop;
  1859. X    }
  1860. X    if (s:/\*:\200:g) {
  1861. X        s:\*/:\201:g;
  1862. X        s/\200[^\201]*\201//g;    # delete single line comments
  1863. X        if (s/\200.*//) {        # begin multi-line comment?
  1864. X        $_ .= '/*';
  1865. X        $_ .= <IN>;
  1866. X        redo;
  1867. X        }
  1868. X    }
  1869. X    if (s/^#\s*//) {
  1870. X        if (s/^define\s+(\w+)//) {
  1871. X        $name = $1;
  1872. X        $new = '';
  1873. X        s/\s+$//;
  1874. X        if (s/^\(([\w,\s]*)\)//) {
  1875. X            $args = $1;
  1876. X            if ($args ne '') {
  1877. X            foreach $arg (split(/,\s*/,$args)) {
  1878. X                $curargs{$arg} = 1;
  1879. X            }
  1880. X            $args =~ s/\b(\w)/\$$1/g;
  1881. X            $args = "local($args) = \@_;\n$t    ";
  1882. X            }
  1883. X            s/^\s+//;
  1884. X            do expr();
  1885. X            $new =~ s/(["\\])/\\$1/g;
  1886. X            if ($t ne '') {
  1887. X            $new =~ s/(['\\])/\\$1/g;
  1888. X            print OUT $t,
  1889. X              "eval 'sub $name {\n$t    ${args}eval \"$new\";\n$t}';\n";
  1890. X            }
  1891. X            else {
  1892. X            print OUT "sub $name {\n    ${args}eval \"$new\";\n}\n";
  1893. X            }
  1894. X            %curargs = ();
  1895. X        }
  1896. X        else {
  1897. X            s/^\s+//;
  1898. X            do expr();
  1899. X            $new = 1 if $new eq '';
  1900. X            if ($t ne '') {
  1901. X            $new =~ s/(['\\])/\\$1/g;
  1902. X            print OUT $t,"eval 'sub $name {",$new,";}';\n";
  1903. X            }
  1904. X            else {
  1905. X            print OUT $t,"sub $name {",$new,";}\n";
  1906. X            }
  1907. X        }
  1908. X        }
  1909. X        elsif (/^include <(.*)>/) {
  1910. X        ($incl = $1) =~ s/\.h$/.ph/;
  1911. X        print OUT $t,"require '$incl';\n";
  1912. X        }
  1913. X        elsif (/^ifdef\s+(\w+)/) {
  1914. X        print OUT $t,"if (defined &$1) {\n";
  1915. X        $tab += 4;
  1916. X        $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
  1917. X        }
  1918. X        elsif (/^ifndef\s+(\w+)/) {
  1919. X        print OUT $t,"if (!defined &$1) {\n";
  1920. X        $tab += 4;
  1921. X        $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
  1922. X        }
  1923. X        elsif (s/^if\s+//) {
  1924. X        $new = '';
  1925. X        do expr();
  1926. X        print OUT $t,"if ($new) {\n";
  1927. X        $tab += 4;
  1928. X        $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
  1929. X        }
  1930. X        elsif (s/^elif\s+//) {
  1931. X        $new = '';
  1932. X        do expr();
  1933. X        $tab -= 4;
  1934. X        $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
  1935. X        print OUT $t,"}\n${t}elsif ($new) {\n";
  1936. X        $tab += 4;
  1937. X        $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
  1938. X        }
  1939. X        elsif (/^else/) {
  1940. X        $tab -= 4;
  1941. X        $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
  1942. X        print OUT $t,"}\n${t}else {\n";
  1943. X        $tab += 4;
  1944. X        $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
  1945. X        }
  1946. X        elsif (/^endif/) {
  1947. X        $tab -= 4;
  1948. X        $t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
  1949. X        print OUT $t,"}\n";
  1950. X        }
  1951. X    }
  1952. X    }
  1953. X    print OUT "1;\n";
  1954. X}
  1955. X
  1956. Xsub expr {
  1957. X    while ($_ ne '') {
  1958. X    s/^(\s+)//        && do {$new .= ' '; next;};
  1959. X    s/^(0x[0-9a-fA-F]+)//    && do {$new .= $1; next;};
  1960. X    s/^(\d+)//        && do {$new .= $1; next;};
  1961. X    s/^("(\\"|[^"])*")//    && do {$new .= $1; next;};
  1962. X    s/^'((\\"|[^"])*)'//    && do {
  1963. X        if ($curargs{$1}) {
  1964. X        $new .= "ord('\$$1')";
  1965. X        }
  1966. X        else {
  1967. X        $new .= "ord('$1')";
  1968. X        }
  1969. X        next;
  1970. X    };
  1971. X    s/^sizeof\s*\(([^)]+)\)/{$1}/ && do {
  1972. X        $new .= '$sizeof';
  1973. X        next;
  1974. X    };
  1975. X    s/^([_a-zA-Z]\w*)//    && do {
  1976. X        $id = $1;
  1977. X        if ($id eq 'struct') {
  1978. X        s/^\s+(\w+)//;
  1979. X        $id .= ' ' . $1;
  1980. X        $isatype{$id} = 1;
  1981. X        }
  1982. X        elsif ($id eq 'unsigned') {
  1983. X        s/^\s+(\w+)//;
  1984. X        $id .= ' ' . $1;
  1985. X        $isatype{$id} = 1;
  1986. X        }
  1987. X        if ($curargs{$id}) {
  1988. X        $new .= '$' . $id;
  1989. X        }
  1990. X        elsif ($id eq 'defined') {
  1991. X        $new .= 'defined';
  1992. X        }
  1993. X        elsif (/^\(/) {
  1994. X        s/^\((\w),/("$1",/ if $id =~ /^_IO[WR]*$/i;    # cheat
  1995. X        $new .= " &$id";
  1996. X        }
  1997. X        elsif ($isatype{$id}) {
  1998. X        if ($new =~ /{\s*$/) {
  1999. X            $new .= "'$id'";
  2000. X        }
  2001. X        elsif ($new =~ /\(\s*$/ && /^[\s*]*\)/) {
  2002. X            $new =~ s/\(\s*$//;
  2003. X            s/^[\s*]*\)//;
  2004. X        }
  2005. X        else {
  2006. X            $new .= $id;
  2007. X        }
  2008. X        }
  2009. X        else {
  2010. X        $new .= ' &' . $id;
  2011. X        }
  2012. X        next;
  2013. X    };
  2014. X    s/^(.)//            && do {$new .= $1; next;};
  2015. X    }
  2016. X}
  2017. X##############################################################################
  2018. X
  2019. X    # These next few lines are legal in both Perl and nroff.
  2020. X
  2021. X.00;            # finish .ig
  2022. X 
  2023. X'di            \" finish diversion--previous line must be blank
  2024. X.nr nl 0-1        \" fake up transition to first page again
  2025. X.nr % 0            \" start at page 1
  2026. X'; __END__ ############# From here on it's a standard manual page ############
  2027. X.TH H2PH 1 "August 8, 1990"
  2028. X.AT 3
  2029. X.SH NAME
  2030. Xh2ph \- convert .h C header files to .ph Perl header files
  2031. X.SH SYNOPSIS
  2032. X.B h2ph [headerfiles]
  2033. X.SH DESCRIPTION
  2034. X.I h2ph
  2035. Xconverts any C header files specified to the corresponding Perl header file
  2036. Xformat.
  2037. XIt is most easily run while in /usr/include:
  2038. X.nf
  2039. X
  2040. X    cd /usr/include; h2ph * sys/*
  2041. X
  2042. X.fi
  2043. XIf run with no arguments, filters standard input to standard output.
  2044. X.SH ENVIRONMENT
  2045. XNo environment variables are used.
  2046. X.SH FILES
  2047. X/usr/include/*.h
  2048. X.br
  2049. X/usr/include/sys/*.h
  2050. X.br
  2051. Xetc.
  2052. X.SH AUTHOR
  2053. XLarry Wall
  2054. X.SH "SEE ALSO"
  2055. Xperl(1)
  2056. X.SH DIAGNOSTICS
  2057. XThe usual warnings if it can't read or write the files involved.
  2058. X.SH BUGS
  2059. XDoesn't construct the %sizeof array for you.
  2060. X.PP
  2061. XIt doesn't handle all C constructs, but it does attempt to isolate
  2062. Xdefinitions inside evals so that you can get at the definitions
  2063. Xthat it can translate.
  2064. X.PP
  2065. XIt's only intended as a rough tool.
  2066. XYou may need to dicker with the files produced.
  2067. X.ex
  2068. X!NO!SUBS!
  2069. Xchmod 755 h2ph
  2070. X$eunicefix h2ph
  2071. Xrm -f h2ph.man
  2072. Xln h2ph h2ph.man
  2073. !STUFFY!FUNK!
  2074. echo " "
  2075. echo "End of kit 11 (of 36)"
  2076. cat /dev/null >kit11isdone
  2077. run=''
  2078. config=''
  2079. 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
  2080.     if test -f kit${iskit}isdone; then
  2081.     run="$run $iskit"
  2082.     else
  2083.     todo="$todo $iskit"
  2084.     fi
  2085. done
  2086. case $todo in
  2087.     '')
  2088.     echo "You have run all your kits.  Please read README and then type Configure."
  2089.     for combo in *:AA; do
  2090.         if test -f "$combo"; then
  2091.         realfile=`basename $combo :AA`
  2092.         cat $realfile:[A-Z][A-Z] >$realfile
  2093.         rm -rf $realfile:[A-Z][A-Z]
  2094.         fi
  2095.     done
  2096.     rm -rf kit*isdone
  2097.     chmod 755 Configure
  2098.     ;;
  2099.     *)  echo "You have run$run."
  2100.     echo "You still need to run$todo."
  2101.     ;;
  2102. esac
  2103. : Someone might mail this, so...
  2104. exit
  2105.  
  2106. exit 0 # Just in case...
  2107. -- 
  2108. Kent Landfield                   INTERNET: kent@sparky.IMD.Sterling.COM
  2109. Sterling Software, IMD           UUCP:     uunet!sparky!kent
  2110. Phone:    (402) 291-8300         FAX:      (402) 291-4362
  2111. Please send comp.sources.misc-related mail to kent@uunet.uu.net.
  2112.