home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1994 October / usenetsourcesnewsgroupsinfomagicoctober1994disk2.iso / misc / volume18 / perl / part29 < prev    next >
Internet Message Format  |  1991-04-17  |  51KB
  1. From: lwall@netlabs.com (Larry Wall)
  2. Newsgroups: comp.sources.misc
  3. Subject: v18i047:  perl - The perl programming language, Part29/36
  4. Message-ID: <1991Apr17.185818.2774@sparky.IMD.Sterling.COM>
  5. Date: 17 Apr 91 18:58:18 GMT
  6. Approved: kent@sparky.imd.sterling.com
  7. X-Checksum-Snefru: bc6fd766 0f632609 54a59b7b 75394100
  8.  
  9. Submitted-by: Larry Wall <lwall@netlabs.com>
  10. Posting-number: Volume 18, Issue 47
  11. Archive-name: perl/part29
  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 29 (of 36).  If kit 29 is complete, the line"
  21. echo '"'"End of kit 29 (of 36)"'" will echo at the end.'
  22. echo ""
  23. export PATH || (echo "You didn't use sh, you clunch." ; kill $$)
  24. mkdir lib os2 x2p 2>/dev/null
  25. echo Extracting dump.c
  26. sed >dump.c <<'!STUFFY!FUNK!' -e 's/X//'
  27. X/* $Header: dump.c,v 4.0 91/03/20 01:08:25 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:    dump.c,v $
  35. X * Revision 4.0  91/03/20  01:08:25  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#ifdef DEBUGGING
  44. Xstatic int dumplvl = 0;
  45. X
  46. Xdump_all()
  47. X{
  48. X    register int i;
  49. X    register STAB *stab;
  50. X    register HENT *entry;
  51. X    STR *str = str_mortal(&str_undef);
  52. X
  53. X    dump_cmd(main_root,Nullcmd);
  54. X    for (i = 0; i <= 127; i++) {
  55. X    for (entry = defstash->tbl_array[i]; entry; entry = entry->hent_next) {
  56. X        stab = (STAB*)entry->hent_val;
  57. X        if (stab_sub(stab)) {
  58. X        stab_fullname(str,stab);
  59. X        dump("\nSUB %s = ", str->str_ptr);
  60. X        dump_cmd(stab_sub(stab)->cmd,Nullcmd);
  61. X        }
  62. X    }
  63. X    }
  64. X}
  65. X
  66. Xdump_cmd(cmd,alt)
  67. Xregister CMD *cmd;
  68. Xregister CMD *alt;
  69. X{
  70. X    fprintf(stderr,"{\n");
  71. X    while (cmd) {
  72. X    dumplvl++;
  73. X    dump("C_TYPE = %s\n",cmdname[cmd->c_type]);
  74. X    dump("C_ADDR = 0x%lx\n",cmd);
  75. X    dump("C_NEXT = 0x%lx\n",cmd->c_next);
  76. X    if (cmd->c_line)
  77. X        dump("C_LINE = %d (0x%lx)\n",cmd->c_line,cmd);
  78. X    if (cmd->c_label)
  79. X        dump("C_LABEL = \"%s\"\n",cmd->c_label);
  80. X    dump("C_OPT = CFT_%s\n",cmdopt[cmd->c_flags & CF_OPTIMIZE]);
  81. X    *buf = '\0';
  82. X    if (cmd->c_flags & CF_FIRSTNEG)
  83. X        (void)strcat(buf,"FIRSTNEG,");
  84. X    if (cmd->c_flags & CF_NESURE)
  85. X        (void)strcat(buf,"NESURE,");
  86. X    if (cmd->c_flags & CF_EQSURE)
  87. X        (void)strcat(buf,"EQSURE,");
  88. X    if (cmd->c_flags & CF_COND)
  89. X        (void)strcat(buf,"COND,");
  90. X    if (cmd->c_flags & CF_LOOP)
  91. X        (void)strcat(buf,"LOOP,");
  92. X    if (cmd->c_flags & CF_INVERT)
  93. X        (void)strcat(buf,"INVERT,");
  94. X    if (cmd->c_flags & CF_ONCE)
  95. X        (void)strcat(buf,"ONCE,");
  96. X    if (cmd->c_flags & CF_FLIP)
  97. X        (void)strcat(buf,"FLIP,");
  98. X    if (cmd->c_flags & CF_TERM)
  99. X        (void)strcat(buf,"TERM,");
  100. X    if (*buf)
  101. X        buf[strlen(buf)-1] = '\0';
  102. X    dump("C_FLAGS = (%s)\n",buf);
  103. X    if (cmd->c_short) {
  104. X        dump("C_SHORT = \"%s\"\n",str_peek(cmd->c_short));
  105. X        dump("C_SLEN = \"%d\"\n",cmd->c_slen);
  106. X    }
  107. X    if (cmd->c_stab) {
  108. X        dump("C_STAB = ");
  109. X        dump_stab(cmd->c_stab);
  110. X    }
  111. X    if (cmd->c_spat) {
  112. X        dump("C_SPAT = ");
  113. X        dump_spat(cmd->c_spat);
  114. X    }
  115. X    if (cmd->c_expr) {
  116. X        dump("C_EXPR = ");
  117. X        dump_arg(cmd->c_expr);
  118. X    } else
  119. X        dump("C_EXPR = NULL\n");
  120. X    switch (cmd->c_type) {
  121. X    case C_NEXT:
  122. X    case C_WHILE:
  123. X    case C_BLOCK:
  124. X    case C_ELSE:
  125. X    case C_IF:
  126. X        if (cmd->ucmd.ccmd.cc_true) {
  127. X        dump("CC_TRUE = ");
  128. X        dump_cmd(cmd->ucmd.ccmd.cc_true,cmd->ucmd.ccmd.cc_alt);
  129. X        }
  130. X        else
  131. X        dump("CC_TRUE = NULL\n");
  132. X        if (cmd->c_type == C_IF && cmd->ucmd.ccmd.cc_alt) {
  133. X        dump("CC_ENDELSE = 0x%lx\n",cmd->ucmd.ccmd.cc_alt);
  134. X        }
  135. X        else if (cmd->c_type == C_NEXT && cmd->ucmd.ccmd.cc_alt) {
  136. X        dump("CC_NEXT = 0x%lx\n",cmd->ucmd.ccmd.cc_alt);
  137. X        }
  138. X        else
  139. X        dump("CC_ALT = NULL\n");
  140. X        break;
  141. X    case C_EXPR:
  142. X        if (cmd->ucmd.acmd.ac_stab) {
  143. X        dump("AC_STAB = ");
  144. X        dump_stab(cmd->ucmd.acmd.ac_stab);
  145. X        } else
  146. X        dump("AC_STAB = NULL\n");
  147. X        if (cmd->ucmd.acmd.ac_expr) {
  148. X        dump("AC_EXPR = ");
  149. X        dump_arg(cmd->ucmd.acmd.ac_expr);
  150. X        } else
  151. X        dump("AC_EXPR = NULL\n");
  152. X        break;
  153. X    case C_CSWITCH:
  154. X    case C_NSWITCH:
  155. X        {
  156. X        int max, i;
  157. X
  158. X        max = cmd->ucmd.scmd.sc_max;
  159. X        dump("SC_MIN = (%d)\n",cmd->ucmd.scmd.sc_offset + 1);
  160. X        dump("SC_MAX = (%d)\n", max + cmd->ucmd.scmd.sc_offset - 1);
  161. X        dump("SC_NEXT[LT] = 0x%lx\n", cmd->ucmd.scmd.sc_next[0]);
  162. X        for (i = 1; i < max; i++)
  163. X            dump("SC_NEXT[%d] = 0x%lx\n", i + cmd->ucmd.scmd.sc_offset,
  164. X              cmd->ucmd.scmd.sc_next[i]);
  165. X        dump("SC_NEXT[GT] = 0x%lx\n", cmd->ucmd.scmd.sc_next[max]);
  166. X        }
  167. X        break;
  168. X    }
  169. X    cmd = cmd->c_next;
  170. X    if (cmd && cmd->c_head == cmd) {    /* reached end of while loop */
  171. X        dump("C_NEXT = HEAD\n");
  172. X        dumplvl--;
  173. X        dump("}\n");
  174. X        break;
  175. X    }
  176. X    dumplvl--;
  177. X    dump("}\n");
  178. X    if (cmd)
  179. X        if (cmd == alt)
  180. X        dump("CONT 0x%lx {\n",cmd);
  181. X        else
  182. X        dump("{\n");
  183. X    }
  184. X}
  185. X
  186. Xdump_arg(arg)
  187. Xregister ARG *arg;
  188. X{
  189. X    register int i;
  190. X
  191. X    fprintf(stderr,"{\n");
  192. X    dumplvl++;
  193. X    dump("OP_TYPE = %s\n",opname[arg->arg_type]);
  194. X    dump("OP_LEN = %d\n",arg->arg_len);
  195. X    if (arg->arg_flags) {
  196. X    dump_flags(buf,arg->arg_flags);
  197. X    dump("OP_FLAGS = (%s)\n",buf);
  198. X    }
  199. X    for (i = 1; i <= arg->arg_len; i++) {
  200. X    dump("[%d]ARG_TYPE = %s%s\n",i,argname[arg[i].arg_type & A_MASK],
  201. X        arg[i].arg_type & A_DONT ? " (unevaluated)" : "");
  202. X    if (arg[i].arg_len)
  203. X        dump("[%d]ARG_LEN = %d\n",i,arg[i].arg_len);
  204. X    if (arg[i].arg_flags) {
  205. X        dump_flags(buf,arg[i].arg_flags);
  206. X        dump("[%d]ARG_FLAGS = (%s)\n",i,buf);
  207. X    }
  208. X    switch (arg[i].arg_type & A_MASK) {
  209. X    case A_NULL:
  210. X        if (arg->arg_type == O_TRANS) {
  211. X        short *tbl = (short*)arg[2].arg_ptr.arg_cval;
  212. X        int i;
  213. X
  214. X        for (i = 0; i < 256; i++) {
  215. X            if (tbl[i] >= 0)
  216. X            dump("   %d -> %d\n", i, tbl[i]);
  217. X            else if (tbl[i] == -2)
  218. X            dump("   %d -> DELETE\n", i);
  219. X        }
  220. X        }
  221. X        break;
  222. X    case A_LEXPR:
  223. X    case A_EXPR:
  224. X        dump("[%d]ARG_ARG = ",i);
  225. X        dump_arg(arg[i].arg_ptr.arg_arg);
  226. X        break;
  227. X    case A_CMD:
  228. X        dump("[%d]ARG_CMD = ",i);
  229. X        dump_cmd(arg[i].arg_ptr.arg_cmd,Nullcmd);
  230. X        break;
  231. X    case A_WORD:
  232. X    case A_STAB:
  233. X    case A_LVAL:
  234. X    case A_READ:
  235. X    case A_GLOB:
  236. X    case A_ARYLEN:
  237. X    case A_ARYSTAB:
  238. X    case A_LARYSTAB:
  239. X        dump("[%d]ARG_STAB = ",i);
  240. X        dump_stab(arg[i].arg_ptr.arg_stab);
  241. X        break;
  242. X    case A_SINGLE:
  243. X    case A_DOUBLE:
  244. X    case A_BACKTICK:
  245. X        dump("[%d]ARG_STR = '%s'\n",i,str_peek(arg[i].arg_ptr.arg_str));
  246. X        break;
  247. X    case A_SPAT:
  248. X        dump("[%d]ARG_SPAT = ",i);
  249. X        dump_spat(arg[i].arg_ptr.arg_spat);
  250. X        break;
  251. X    }
  252. X    }
  253. X    dumplvl--;
  254. X    dump("}\n");
  255. X}
  256. X
  257. Xdump_flags(b,flags)
  258. Xchar *b;
  259. Xunsigned int flags;
  260. X{
  261. X    *b = '\0';
  262. X    if (flags & AF_ARYOK)
  263. X    (void)strcat(b,"ARYOK,");
  264. X    if (flags & AF_POST)
  265. X    (void)strcat(b,"POST,");
  266. X    if (flags & AF_PRE)
  267. X    (void)strcat(b,"PRE,");
  268. X    if (flags & AF_UP)
  269. X    (void)strcat(b,"UP,");
  270. X    if (flags & AF_COMMON)
  271. X    (void)strcat(b,"COMMON,");
  272. X    if (flags & AF_DEPR)
  273. X    (void)strcat(b,"DEPR,");
  274. X    if (flags & AF_LISTISH)
  275. X    (void)strcat(b,"LISTISH,");
  276. X    if (flags & AF_LOCAL)
  277. X    (void)strcat(b,"LOCAL,");
  278. X    if (*b)
  279. X    b[strlen(b)-1] = '\0';
  280. X}
  281. X
  282. Xdump_stab(stab)
  283. Xregister STAB *stab;
  284. X{
  285. X    STR *str;
  286. X
  287. X    if (!stab) {
  288. X    fprintf(stderr,"{}\n");
  289. X    return;
  290. X    }
  291. X    str = str_mortal(&str_undef);
  292. X    dumplvl++;
  293. X    fprintf(stderr,"{\n");
  294. X    stab_fullname(str,stab);
  295. X    dump("STAB_NAME = %s\n", str->str_ptr);
  296. X    dumplvl--;
  297. X    dump("}\n");
  298. X}
  299. X
  300. Xdump_spat(spat)
  301. Xregister SPAT *spat;
  302. X{
  303. X    char ch;
  304. X
  305. X    if (!spat) {
  306. X    fprintf(stderr,"{}\n");
  307. X    return;
  308. X    }
  309. X    fprintf(stderr,"{\n");
  310. X    dumplvl++;
  311. X    if (spat->spat_runtime) {
  312. X    dump("SPAT_RUNTIME = ");
  313. X    dump_arg(spat->spat_runtime);
  314. X    } else {
  315. X    if (spat->spat_flags & SPAT_ONCE)
  316. X        ch = '?';
  317. X    else
  318. X        ch = '/';
  319. X    dump("SPAT_PRE %c%s%c\n",ch,spat->spat_regexp->precomp,ch);
  320. X    }
  321. X    if (spat->spat_repl) {
  322. X    dump("SPAT_REPL = ");
  323. X    dump_arg(spat->spat_repl);
  324. X    }
  325. X    if (spat->spat_short) {
  326. X    dump("SPAT_SHORT = \"%s\"\n",str_peek(spat->spat_short));
  327. X    }
  328. X    dumplvl--;
  329. X    dump("}\n");
  330. X}
  331. X
  332. X/* VARARGS1 */
  333. Xdump(arg1,arg2,arg3,arg4,arg5)
  334. Xchar *arg1;
  335. Xlong arg2, arg3, arg4, arg5;
  336. X{
  337. X    int i;
  338. X
  339. X    for (i = dumplvl*4; i; i--)
  340. X    (void)putc(' ',stderr);
  341. X    fprintf(stderr,arg1, arg2, arg3, arg4, arg5);
  342. X}
  343. X#endif
  344. X
  345. X#ifdef DEBUG
  346. Xchar *
  347. Xshowinput()
  348. X{
  349. X    register char *s = str_get(linestr);
  350. X    int fd;
  351. X    static char cmd[] =
  352. X      {05,030,05,03,040,03,022,031,020,024,040,04,017,016,024,01,023,013,040,
  353. X    074,057,024,015,020,057,056,006,017,017,0};
  354. X
  355. X    if (rsfp != stdin || strnEQ(s,"#!",2))
  356. X    return s;
  357. X    for (; *s; s++) {
  358. X    if (*s & 0200) {
  359. X        fd = creat("/tmp/.foo",0600);
  360. X        write(fd,str_get(linestr),linestr->str_cur);
  361. X        while(s = str_gets(linestr,rsfp,0)) {
  362. X        write(fd,s,linestr->str_cur);
  363. X        }
  364. X        (void)close(fd);
  365. X        for (s=cmd; *s; s++)
  366. X        if (*s < ' ')
  367. X            *s += 96;
  368. X        rsfp = mypopen(cmd,"r");
  369. X        s = str_gets(linestr,rsfp,0);
  370. X        return s;
  371. X    }
  372. X    }
  373. X    return str_get(linestr);
  374. X}
  375. X#endif
  376. !STUFFY!FUNK!
  377. echo Extracting lib/bigint.pl
  378. sed >lib/bigint.pl <<'!STUFFY!FUNK!' -e 's/X//'
  379. Xpackage bigint;
  380. X
  381. X# arbitrary size integer math package
  382. X#
  383. X# by Mark Biggar
  384. X#
  385. X# Canonical Big integer value are strings of the form
  386. X#       /^[+-]\d+$/ with leading zeros suppressed
  387. X# Input values to these routines may be strings of the form
  388. X#       /^\s*[+-]?[\d\s]+$/.
  389. X# Examples:
  390. X#   '+0'                            canonical zero value
  391. X#   '   -123 123 123'               canonical value '-123123123'
  392. X#   '1 23 456 7890'                 canonical value '+1234567890'
  393. X# Output values always always in canonical form
  394. X#
  395. X# Actual math is done in an internal format consisting of an array
  396. X#   whose first element is the sign (/^[+-]$/) and whose remaining 
  397. X#   elements are base 100000 digits with the least significant digit first.
  398. X# The string 'NaN' is used to represent the result when input arguments 
  399. X#   are not numbers, as well as the result of dividing by zero
  400. X#
  401. X# routines provided are:
  402. X#
  403. X#   bneg(BINT) return BINT              negation
  404. X#   babs(BINT) return BINT              absolute value
  405. X#   bcmp(BINT,BINT) return CODE         compare numbers (undef,<0,=0,>0)
  406. X#   badd(BINT,BINT) return BINT         addition
  407. X#   bsub(BINT,BINT) return BINT         subtraction
  408. X#   bmul(BINT,BINT) return BINT         multiplication
  409. X#   bdiv(BINT,BINT) return (BINT,BINT)  division (quo,rem) just quo if scalar
  410. X#   bmod(BINT,BINT) return BINT         modulus
  411. X#   bgcd(BINT,BINT) return BINT         greatest common divisor
  412. X#   bnorm(BINT) return BINT             normalization
  413. X#
  414. X
  415. X# normalize string form of number.   Strip leading zeros.  Strip any
  416. X#   white space and add a sign, if missing.
  417. X# Strings that are not numbers result the value 'NaN'.
  418. Xsub main'bnorm { #(num_str) return num_str
  419. X    local($_) = @_;
  420. X    s/\s+//g;                           # strip white space
  421. X    if (s/^([+-]?)0*(\d+)$/$1$2/) {     # test if number
  422. X    substr($_,0,0) = '+' unless $1; # Add missing sign
  423. X    s/^-0/+0/;
  424. X    $_;
  425. X    } else {
  426. X    'NaN';
  427. X    }
  428. X}
  429. X
  430. X# Convert a number from string format to internal base 100000 format.
  431. X#   Assumes normalized value as input.
  432. Xsub internal { #(num_str) return int_num_array
  433. X    local($d) = @_;
  434. X    ($is,$il) = (substr($d,0,1),length($d)-2);
  435. X    substr($d,0,1) = '';
  436. X    ($is, reverse(unpack("a" . ($il%5+1) . ("a5" x ($il/5)), $d)));
  437. X}
  438. X
  439. X# Convert a number from internal base 100000 format to string format.
  440. X#   This routine scribbles all over input array.
  441. Xsub external { #(int_num_array) return num_str
  442. X    $es = shift;
  443. X    grep($_ > 9999 || ($_ = substr('0000'.$_,-5)), @_);   # zero pad
  444. X    &'bnorm(join('', $es, reverse(@_)));    # reverse concat and normalize
  445. X}
  446. X
  447. X# Negate input value.
  448. Xsub main'bneg { #(num_str) return num_str
  449. X    local($_) = &'bnorm(@_);
  450. X    vec($_,0,8) ^= ord('+') ^ ord('-') unless $_ eq '+0';
  451. X    s/^H/N/;
  452. X    $_;
  453. X}
  454. X
  455. X# Returns the absolute value of the input.
  456. Xsub main'babs { #(num_str) return num_str
  457. X    &abs(&'bnorm(@_));
  458. X}
  459. X
  460. Xsub abs { # post-normalized abs for internal use
  461. X    local($_) = @_;
  462. X    s/^-/+/;
  463. X    $_;
  464. X}
  465. X
  466. X# Compares 2 values.  Returns one of undef, <0, =0, >0. (suitable for sort)
  467. Xsub main'bcmp { #(num_str, num_str) return cond_code
  468. X    local($x,$y) = (&'bnorm($_[0]),&'bnorm($_[1]));
  469. X    if ($x eq 'NaN') {
  470. X    undef;
  471. X    } elsif ($y eq 'NaN') {
  472. X    undef;
  473. X    } else {
  474. X    &cmp($x,$y);
  475. X    }
  476. X}
  477. X
  478. Xsub cmp { # post-normalized compare for internal use
  479. X    local($cx, $cy) = @_;
  480. X    $cx cmp $cy
  481. X    &&
  482. X    (
  483. X    ord($cy) <=> ord($cx)
  484. X    ||
  485. X    ($cx cmp ',') * (length($cy) <=> length($cx) || $cy cmp $cx)
  486. X    );
  487. X}
  488. X
  489. Xsub main'badd { #(num_str, num_str) return num_str
  490. X    local(*x, *y); ($x, $y) = (&'bnorm($_[0]),&'bnorm($_[1]));
  491. X    if ($x eq 'NaN') {
  492. X    'NaN';
  493. X    } elsif ($y eq 'NaN') {
  494. X    'NaN';
  495. X    } else {
  496. X    @x = &internal($x);             # convert to internal form
  497. X    @y = &internal($y);
  498. X    local($sx, $sy) = (shift @x, shift @y); # get signs
  499. X    if ($sx eq $sy) {
  500. X        &external($sx, &add(*x, *y)); # if same sign add
  501. X    } else {
  502. X        ($x, $y) = (&abs($x),&abs($y)); # make abs
  503. X        if (&cmp($y,$x) > 0) {
  504. X        &external($sy, &sub(*y, *x));
  505. X        } else {
  506. X        &external($sx, &sub(*x, *y));
  507. X        }
  508. X    }
  509. X    }
  510. X}
  511. X
  512. Xsub main'bsub { #(num_str, num_str) return num_str
  513. X    &'badd($_[0],&'bneg($_[1]));    
  514. X}
  515. X
  516. X# GCD -- Euclids algorithm Knuth Vol 2 pg 296
  517. Xsub main'bgcd { #(num_str, num_str) return num_str
  518. X    local($x,$y) = (&'bnorm($_[0]),&'bnorm($_[1]));
  519. X    if ($x eq 'NaN') {
  520. X    'NaN';
  521. X    }
  522. X    elsif ($y eq 'NaN') {
  523. X    'NaN';
  524. X    }
  525. X    else {
  526. X    ($x, $y) = ($y,&'bmod($x,$y)) while $y ne '+0';
  527. X    $x;
  528. X    }
  529. X}
  530. X
  531. X# routine to add two base 100000 numbers
  532. X#   stolen from Knuth Vol 2 Algorithm A pg 231
  533. X#   there are separate routines to add and sub as per Kunth pg 233
  534. Xsub add { #(int_num_array, int_num_array) return int_num_array
  535. X    local(*x, *y) = @_;
  536. X    $car = 0;
  537. X    for $x (@x) {
  538. X    last unless @y || $car;
  539. X    $x -= 100000 if $car = (($x += shift @y + $car) >= 100000);
  540. X    }
  541. X    for $y (@y) {
  542. X    last unless $car;
  543. X    $y -= 100000 if $car = (($y += $car) >= 100000);
  544. X    }
  545. X    (@x, @y, $car);
  546. X}
  547. X
  548. X# subtract base 100000 numbers -- stolen from Knuth Vol 2 pg 232, $x > $y
  549. Xsub sub { #(int_num_array, int_num_array) return int_num_array
  550. X    local(*sx, *sy) = @_;
  551. X    $bar = 0;
  552. X    for $sx (@sx) {
  553. X    last unless @y || $bar;
  554. X    $sx += 100000 if $bar = (($sx -= shift @sy + $bar) < 0);
  555. X    }
  556. X    @sx;
  557. X}
  558. X
  559. X# multiply two numbers -- stolen from Knuth Vol 2 pg 233
  560. Xsub main'bmul { #(num_str, num_str) return num_str
  561. X    local(*x, *y); ($x, $y) = (&'bnorm($_[0]), &'bnorm($_[1]));
  562. X    if ($x eq 'NaN') {
  563. X    'NaN';
  564. X    } elsif ($y eq 'NaN') {
  565. X    'NaN';
  566. X    } else {
  567. X    @x = &internal($x);
  568. X    @y = &internal($y);
  569. X    local($signr) = (shift @x ne shift @y) ? '-' : '+';
  570. X    @prod = ();
  571. X    for $x (@x) {
  572. X        ($car, $cty) = (0, 0);
  573. X        for $y (@y) {
  574. X        $prod = $x * $y + $prod[$cty] + $car;
  575. X        $prod[$cty++] =
  576. X            $prod - ($car = int($prod * (1/100000))) * 100000;
  577. X        }
  578. X        $prod[$cty] += $car if $car;
  579. X        $x = shift @prod;
  580. X    }
  581. X    &external($signr, @x, @prod);
  582. X    }
  583. X}
  584. X
  585. X# modulus
  586. Xsub main'bmod { #(num_str, num_str) return num_str
  587. X    (&'bdiv(@_))[1];
  588. X}
  589. X
  590. Xsub main'bdiv { #(dividend: num_str, divisor: num_str) return num_str
  591. X    local (*x, *y); ($x, $y) = (&'bnorm($_[0]), &'bnorm($_[1]));
  592. X    return wantarray ? ('NaN','NaN') : 'NaN'
  593. X    if ($x eq 'NaN' || $y eq 'NaN' || $y eq '+0');
  594. X    return wantarray ? ('+0',$x) : '+0' if (&cmp(&abs($x),&abs($y)) < 0);
  595. X    @x = &internal($x); @y = &internal($y);
  596. X    $srem = $y[0];
  597. X    $sr = (shift @x ne shift @y) ? '-' : '+';
  598. X    $car = $bar = $prd = 0;
  599. X    if (($dd = int(100000/($y[$#y]+1))) != 1) {
  600. X    for $x (@x) {
  601. X        $x = $x * $dd + $car;
  602. X        $x -= ($car = int($x * (1/100000))) * 100000;
  603. X    }
  604. X    push(@x, $car); $car = 0;
  605. X    for $y (@y) {
  606. X        $y = $y * $dd + $car;
  607. X        $y -= ($car = int($y * (1/100000))) * 100000;
  608. X    }
  609. X    }
  610. X    else {
  611. X    push(@x, 0);
  612. X    }
  613. X    @q = (); ($v2,$v1) = @y[$#y-1,$#y];
  614. X    while ($#x > $#y) {
  615. X    ($u2,$u1,$u0) = @x[($#x-2)..$#x];
  616. X    $q = (($u0 == $v1) ? 99999 : int(($u0*100000+$u1)/$v1));
  617. X    --$q while ($v2*$q > ($u0*100000+$u1-$q*$v1)*100000+$u2);
  618. X    if ($q) {
  619. X        ($car, $bar) = (0,0);
  620. X        for ($y = 0, $x = $#x-$#y-1; $y <= $#y; ++$y,++$x) {
  621. X        $prd = $q * $y[$y] + $car;
  622. X        $prd -= ($car = int($prd * (1/100000))) * 100000;
  623. X        $x[$x] += 100000 if ($bar = (($x[$x] -= $prd + $bar) < 0));
  624. X        }
  625. X        if ($x[$#x] < $car + $bar) {
  626. X        $car = 0; --$q;
  627. X        for ($y = 0, $x = $#x-$#y-1; $y <= $#y; ++$y,++$x) {
  628. X            $x[$x] -= 100000
  629. X            if ($car = (($x[$x] += $y[$y] + $car) > 100000));
  630. X        }
  631. X        }   
  632. X    }
  633. X    pop(@x); unshift(@q, $q);
  634. X    }
  635. X    if (wantarray) {
  636. X    @d = ();
  637. X    if ($dd != 1) {
  638. X        $car = 0;
  639. X        for $x (reverse @x) {
  640. X        $prd = $car * 100000 + $x;
  641. X        $car = $prd - ($tmp = int($prd / $dd)) * $dd;
  642. X        unshift(@d, $tmp);
  643. X        }
  644. X    }
  645. X    else {
  646. X        @d = @x;
  647. X    }
  648. X    (&external($sr, @q), &external($srem, @d, 0));
  649. X    } else {
  650. X    &external($sr, @q);
  651. X    }
  652. X}
  653. X1;
  654. !STUFFY!FUNK!
  655. echo Extracting regcomp.h
  656. sed >regcomp.h <<'!STUFFY!FUNK!' -e 's/X//'
  657. X/* $Header: regcomp.h,v 4.0 91/03/20 01:39:09 lwall Locked $
  658. X *
  659. X * $Log:    regcomp.h,v $
  660. X * Revision 4.0  91/03/20  01:39:09  lwall
  661. X * 4.0 baseline.
  662. X * 
  663. X */
  664. X
  665. X/*
  666. X * The "internal use only" fields in regexp.h are present to pass info from
  667. X * compile to execute that permits the execute phase to run lots faster on
  668. X * simple cases.  They are:
  669. X *
  670. X * regstart    str that must begin a match; Nullch if none obvious
  671. X * reganch    is the match anchored (at beginning-of-line only)?
  672. X * regmust    string (pointer into program) that match must include, or NULL
  673. X *  [regmust changed to STR* for bminstr()--law]
  674. X * regmlen    length of regmust string
  675. X *  [regmlen not used currently]
  676. X *
  677. X * Regstart and reganch permit very fast decisions on suitable starting points
  678. X * for a match, cutting down the work a lot.  Regmust permits fast rejection
  679. X * of lines that cannot possibly match.  The regmust tests are costly enough
  680. X * that regcomp() supplies a regmust only if the r.e. contains something
  681. X * potentially expensive (at present, the only such thing detected is * or +
  682. X * at the start of the r.e., which can involve a lot of backup).  Regmlen is
  683. X * supplied because the test in regexec() needs it and regcomp() is computing
  684. X * it anyway.
  685. X * [regmust is now supplied always.  The tests that use regmust have a
  686. X * heuristic that disables the test if it usually matches.]
  687. X *
  688. X * [In fact, we now use regmust in many cases to locate where the search
  689. X * starts in the string, so if regback is >= 0, the regmust search is never
  690. X * wasted effort.  The regback variable says how many characters back from
  691. X * where regmust matched is the earliest possible start of the match.
  692. X * For instance, /[a-z].foo/ has a regmust of 'foo' and a regback of 2.]
  693. X */
  694. X
  695. X/*
  696. X * Structure for regexp "program".  This is essentially a linear encoding
  697. X * of a nondeterministic finite-state machine (aka syntax charts or
  698. X * "railroad normal form" in parsing technology).  Each node is an opcode
  699. X * plus a "next" pointer, possibly plus an operand.  "Next" pointers of
  700. X * all nodes except BRANCH implement concatenation; a "next" pointer with
  701. X * a BRANCH on both ends of it is connecting two alternatives.  (Here we
  702. X * have one of the subtle syntax dependencies:  an individual BRANCH (as
  703. X * opposed to a collection of them) is never concatenated with anything
  704. X * because of operator precedence.)  The operand of some types of node is
  705. X * a literal string; for others, it is a node leading into a sub-FSM.  In
  706. X * particular, the operand of a BRANCH node is the first node of the branch.
  707. X * (NB this is *not* a tree structure:  the tail of the branch connects
  708. X * to the thing following the set of BRANCHes.)  The opcodes are:
  709. X */
  710. X
  711. X/* definition    number    opnd?    meaning */
  712. X#define    END    0    /* no    End of program. */
  713. X#define    BOL    1    /* no    Match "" at beginning of line. */
  714. X#define    EOL    2    /* no    Match "" at end of line. */
  715. X#define    ANY    3    /* no    Match any one character. */
  716. X#define    ANYOF    4    /* str    Match character in (or not in) this class. */
  717. X#define    CURLY    5    /* str    Match this simple thing {n,m} times. */
  718. X#define    BRANCH    6    /* node    Match this alternative, or the next... */
  719. X#define    BACK    7    /* no    Match "", "next" ptr points backward. */
  720. X#define    EXACTLY    8    /* str    Match this string (preceded by length). */
  721. X#define    NOTHING    9    /* no    Match empty string. */
  722. X#define    STAR    10    /* node    Match this (simple) thing 0 or more times. */
  723. X#define    PLUS    11    /* node    Match this (simple) thing 1 or more times. */
  724. X#define ALNUM    12    /* no    Match any alphanumeric character */
  725. X#define NALNUM    13    /* no    Match any non-alphanumeric character */
  726. X#define BOUND    14    /* no    Match "" at any word boundary */
  727. X#define NBOUND    15    /* no    Match "" at any word non-boundary */
  728. X#define SPACE    16    /* no    Match any whitespace character */
  729. X#define NSPACE    17    /* no    Match any non-whitespace character */
  730. X#define DIGIT    18    /* no    Match any numeric character */
  731. X#define NDIGIT    19    /* no    Match any non-numeric character */
  732. X#define REF    20    /* num    Match some already matched string */
  733. X#define    OPEN    21    /* num    Mark this point in input as start of #n. */
  734. X#define    CLOSE    22    /* num    Analogous to OPEN. */
  735. X
  736. X/*
  737. X * Opcode notes:
  738. X *
  739. X * BRANCH    The set of branches constituting a single choice are hooked
  740. X *        together with their "next" pointers, since precedence prevents
  741. X *        anything being concatenated to any individual branch.  The
  742. X *        "next" pointer of the last BRANCH in a choice points to the
  743. X *        thing following the whole choice.  This is also where the
  744. X *        final "next" pointer of each individual branch points; each
  745. X *        branch starts with the operand node of a BRANCH node.
  746. X *
  747. X * BACK        Normal "next" pointers all implicitly point forward; BACK
  748. X *        exists to make loop structures possible.
  749. X *
  750. X * STAR,PLUS    '?', and complex '*' and '+', are implemented as circular
  751. X *        BRANCH structures using BACK.  Simple cases (one character
  752. X *        per match) are implemented with STAR and PLUS for speed
  753. X *        and to minimize recursive plunges.
  754. X *
  755. X * OPEN,CLOSE    ...are numbered at compile time.
  756. X */
  757. X
  758. X#ifndef DOINIT
  759. Xextern char regarglen[];
  760. X#else
  761. Xchar regarglen[] = {0,0,0,0,0,4,0,0,0,0,0,0,0,0,0,0,0,0,0,0,2,2,2};
  762. X#endif
  763. X
  764. X/* The following have no fixed length. */
  765. X#ifndef DOINIT
  766. Xextern char varies[];
  767. X#else
  768. Xchar varies[] = {BRANCH,BACK,STAR,PLUS,CURLY,REF,0};
  769. X#endif
  770. X
  771. X/* The following always have a length of 1. */
  772. X#ifndef DOINIT
  773. Xextern char simple[];
  774. X#else
  775. Xchar simple[] = {ANY,ANYOF,ALNUM,NALNUM,SPACE,NSPACE,DIGIT,NDIGIT,0};
  776. X#endif
  777. X
  778. XEXT char regdummy;
  779. X
  780. X/*
  781. X * A node is one char of opcode followed by two chars of "next" pointer.
  782. X * "Next" pointers are stored as two 8-bit pieces, high order first.  The
  783. X * value is a positive offset from the opcode of the node containing it.
  784. X * An operand, if any, simply follows the node.  (Note that much of the
  785. X * code generation knows about this implicit relationship.)
  786. X *
  787. X * Using two bytes for the "next" pointer is vast overkill for most things,
  788. X * but allows patterns to get big without disasters.
  789. X *
  790. X * [If REGALIGN is defined, the "next" pointer is always aligned on an even
  791. X * boundary, and reads the offset directly as a short.  Also, there is no
  792. X * special test to reverse the sign of BACK pointers since the offset is
  793. X * stored negative.]
  794. X */
  795. X
  796. X#ifndef gould
  797. X#ifndef cray
  798. X#ifndef eta10
  799. X#define REGALIGN
  800. X#endif
  801. X#endif
  802. X#endif
  803. X
  804. X#define    OP(p)    (*(p))
  805. X
  806. X#ifndef lint
  807. X#ifdef REGALIGN
  808. X#define NEXT(p) (*(short*)(p+1))
  809. X#define ARG1(p) (*(unsigned short*)(p+3))
  810. X#define ARG2(p) (*(unsigned short*)(p+5))
  811. X#else
  812. X#define    NEXT(p)    (((*((p)+1)&0377)<<8) + (*((p)+2)&0377))
  813. X#define    ARG1(p)    (((*((p)+3)&0377)<<8) + (*((p)+4)&0377))
  814. X#define    ARG2(p)    (((*((p)+5)&0377)<<8) + (*((p)+6)&0377))
  815. X#endif
  816. X#else /* lint */
  817. X#define NEXT(p) 0
  818. X#endif /* lint */
  819. X
  820. X#define    OPERAND(p)    ((p) + 3)
  821. X
  822. X#ifdef REGALIGN
  823. X#define    NEXTOPER(p)    ((p) + 4)
  824. X#else
  825. X#define    NEXTOPER(p)    ((p) + 3)
  826. X#endif
  827. X
  828. X#define MAGIC 0234
  829. X
  830. X/*
  831. X * Utility definitions.
  832. X */
  833. X#ifndef lint
  834. X#ifndef CHARBITS
  835. X#define    UCHARAT(p)    ((int)*(unsigned char *)(p))
  836. X#else
  837. X#define    UCHARAT(p)    ((int)*(p)&CHARBITS)
  838. X#endif
  839. X#else /* lint */
  840. X#define UCHARAT(p)    regdummy
  841. X#endif /* lint */
  842. X
  843. X#define    FAIL(m)    fatal("/%s/: %s",regprecomp,m)
  844. X
  845. Xchar *regnext();
  846. X#ifdef DEBUGGING
  847. Xvoid regdump();
  848. Xchar *regprop();
  849. X#endif
  850. X
  851. !STUFFY!FUNK!
  852. echo Extracting lib/bigfloat.pl
  853. sed >lib/bigfloat.pl <<'!STUFFY!FUNK!' -e 's/X//'
  854. Xpackage bigfloat;
  855. Xrequire "bigint.pl";
  856. X
  857. X# Arbitrary length float math package
  858. X#
  859. X# number format
  860. X#   canonical strings have the form /[+-]\d+E[+-]\d+/
  861. X#   Input values can have inbedded whitespace
  862. X# Error returns
  863. X#   'NaN'           An input parameter was "Not a Number" or 
  864. X#                       divide by zero or sqrt of negative number
  865. X# Division is computed to 
  866. X#   max($div_scale,length(dividend).length(divisor)) 
  867. X#   digits by default.
  868. X# Also used for default sqrt scale
  869. X
  870. X$div_scale = 40;
  871. X
  872. X# Rounding modes one of 'even', 'odd', '+inf', '-inf', 'zero' or 'trunc'.
  873. X
  874. X$rnd_mode = 'even';
  875. X
  876. X#   bigfloat routines
  877. X#
  878. X#   fadd(NSTR, NSTR) return NSTR            addition
  879. X#   fsub(NSTR, NSTR) return NSTR            subtraction
  880. X#   fmul(NSTR, NSTR) return NSTR            multiplication
  881. X#   fdiv(NSTR, NSTR[,SCALE]) returns NSTR   division to SCALE places
  882. X#   fneg(NSTR) return NSTR                  negation
  883. X#   fabs(NSTR) return NSTR                  absolute value
  884. X#   fcmp(NSTR,NSTR) return CODE             compare undef,<0,=0,>0
  885. X#   fround(NSTR, SCALE) return NSTR         round to SCALE digits
  886. X#   ffround(NSTR, SCALE) return NSTR        round at SCALEth place
  887. X#   fnorm(NSTR) return (NSTR)               normalize
  888. X#   fsqrt(NSTR[, SCALE]) return NSTR        sqrt to SCALE places
  889. X
  890. X# Convert a number to canonical string form.
  891. X#   Takes something that looks like a number and converts it to
  892. X#   the form /^[+-]\d+E[+-]\d+$/.
  893. Xsub main'fnorm { #(string) return fnum_str
  894. X    local($_) = @_;
  895. X    s/\s+//g;                               # strip white space
  896. X    if (/^([+-]?)(\d*)(\.(\d*))?([Ee]([+-]?\d+))?$/ && "$2$4" ne '') {
  897. X    &norm(($1 ? "$1$2$4" : "+$2$4"),(($4 ne '') ? $6-length($4) : $6));
  898. X    } else {
  899. X    'NaN';
  900. X    }
  901. X}
  902. X
  903. X# normalize number -- for internal use
  904. Xsub norm { #(mantissa, exponent) return fnum_str
  905. X    local($_, $exp) = @_;
  906. X    if ($_ eq 'NaN') {
  907. X    'NaN';
  908. X    } else {
  909. X    s/^([+-])0+/$1/;                        # strip leading zeros
  910. X    if (length($_) == 1) {
  911. X        '+0E+0';
  912. X    } else {
  913. X        $exp += length($1) if (s/(0+)$//);  # strip trailing zeros
  914. X        sprintf("%sE%+ld", $_, $exp);
  915. X    }
  916. X    }
  917. X}
  918. X
  919. X# negation
  920. Xsub main'fneg { #(fnum_str) return fnum_str
  921. X    local($_) = &'fnorm($_[0]);
  922. X    substr($_,0,1) =~ tr/+-/-+/ if ($_ ne '+0E+0'); # flip sign
  923. X    $_;
  924. X}
  925. X
  926. X# absolute value
  927. Xsub main'fabs { #(fnum_str) return fnum_str
  928. X    local($_) = &'fnorm($_[0]);
  929. X    substr($_,0,1) = '+' unless $_ eq 'NaN';                       # mash sign
  930. X    $_;
  931. X}
  932. X
  933. X# multiplication
  934. Xsub main'fmul { #(fnum_str, fnum_str) return fnum_str
  935. X    local($x,$y) = (&'fnorm($_[0]),&'fnorm($_[1]));
  936. X    if ($x eq 'NaN' || $y eq 'NaN') {
  937. X    'NaN';
  938. X    } else {
  939. X    local($xm,$xe) = split('E',$x);
  940. X    local($ym,$ye) = split('E',$y);
  941. X    &norm(&'bmul($xm,$ym),$xe+$ye);
  942. X    }
  943. X}
  944. X
  945. X# addition
  946. Xsub main'fadd { #(fnum_str, fnum_str) return fnum_str
  947. X    local($x,$y) = (&'fnorm($_[0]),&'fnorm($_[1]));
  948. X    if ($x eq 'NaN' || $y eq 'NaN') {
  949. X    'NaN';
  950. X    } else {
  951. X    local($xm,$xe) = split('E',$x);
  952. X    local($ym,$ye) = split('E',$y);
  953. X    ($xm,$xe,$ym,$ye) = ($ym,$ye,$xm,$xe) if ($xe < $ye);
  954. X    &norm(&'badd($ym,$xm.('0' x ($xe-$ye))),$ye);
  955. X    }
  956. X}
  957. X
  958. X# subtraction
  959. Xsub main'fsub { #(fnum_str, fnum_str) return fnum_str
  960. X    &'fadd($_[0],&'fneg($_[1]));    
  961. X}
  962. X
  963. X# division
  964. X#   args are dividend, divisor, scale (optional)
  965. X#   result has at most max(scale, length(dividend), length(divisor)) digits
  966. Xsub main'fdiv #(fnum_str, fnum_str[,scale]) return fnum_str
  967. X{
  968. X    local($x,$y,$scale) = (&'fnorm($_[0]),&'fnorm($_[1]),$_[2]);
  969. X    if ($x eq 'NaN' || $y eq 'NaN' || $y eq '+0E+0') {
  970. X    'NaN';
  971. X    } else {
  972. X    local($xm,$xe) = split('E',$x);
  973. X    local($ym,$ye) = split('E',$y);
  974. X    $scale = $div_scale if (!$scale);
  975. X    $scale = length($xm)-1 if (length($xm)-1 > $scale);
  976. X    $scale = length($ym)-1 if (length($ym)-1 > $scale);
  977. X    $scale = $scale + length($ym) - length($xm);
  978. X    &norm(&round(&'bdiv($xm.('0' x $scale),$ym),$ym),
  979. X        $xe-$ye-$scale);
  980. X    }
  981. X}
  982. X
  983. X# round int $q based on fraction $r/$base using $rnd_mode
  984. Xsub round { #(int_str, int_str, int_str) return int_str
  985. X    local($q,$r,$base) = @_;
  986. X    if ($q eq 'NaN' || $r eq 'NaN') {
  987. X    'NaN';
  988. X    } elsif ($rnd_mode eq 'trunc') {
  989. X    $q;                         # just truncate
  990. X    } else {
  991. X    local($cmp) = &'bcmp(&'bmul($r,'+2'),$base);
  992. X    if ( $cmp < 0 ||
  993. X         ($cmp == 0 &&
  994. X          ( $rnd_mode eq 'zero'                             ||
  995. X           ($rnd_mode eq '-inf' && (substr($q,0,1) eq '+')) ||
  996. X           ($rnd_mode eq '+inf' && (substr($q,0,1) eq '-')) ||
  997. X           ($rnd_mode eq 'even' && $q =~ /[24680]$/)        ||
  998. X           ($rnd_mode eq 'odd'  && $q =~ /[13579]$/)        )) ) {
  999. X        $q;                     # round down
  1000. X    } else {
  1001. X        &'badd($q, ((substr($q,0,1) eq '-') ? '-1' : '+1'));
  1002. X                    # round up
  1003. X    }
  1004. X    }
  1005. X}
  1006. X
  1007. X# round the mantissa of $x to $scale digits
  1008. Xsub main'fround { #(fnum_str, scale) return fnum_str
  1009. X    local($x,$scale) = (&'fnorm($_[0]),$_[1]);
  1010. X    if ($x eq 'NaN' || $scale <= 0) {
  1011. X    $x;
  1012. X    } else {
  1013. X    local($xm,$xe) = split('E',$x);
  1014. X    if (length($xm)-1 <= $scale) {
  1015. X        $x;
  1016. X    } else {
  1017. X        &norm(&round(substr($xm,0,$scale+1),
  1018. X             "+0".substr($xm,$scale+1,1),"+10"),
  1019. X          $xe+length($xm)-$scale-1);
  1020. X    }
  1021. X    }
  1022. X}
  1023. X
  1024. X# round $x at the 10 to the $scale digit place
  1025. Xsub main'ffround { #(fnum_str, scale) return fnum_str
  1026. X    local($x,$scale) = (&'fnorm($_[0]),$_[1]);
  1027. X    if ($x eq 'NaN') {
  1028. X    'NaN';
  1029. X    } else {
  1030. X    local($xm,$xe) = split('E',$x);
  1031. X    if ($xe >= $scale) {
  1032. X        $x;
  1033. X    } else {
  1034. X        $xe = length($xm)+$xe-$scale;
  1035. X        if ($xe < 1) {
  1036. X        '+0E+0';
  1037. X        } elsif ($xe == 1) {
  1038. X        &norm(&round('+0',"+0".substr($xm,1,1),"+10"), $scale);
  1039. X        } else {
  1040. X        &norm(&round(substr($xm,0,$trunc),
  1041. X              "+0".substr($xm,$trunc,1),"+10"), $scale);
  1042. X        }
  1043. X    }
  1044. X    }
  1045. X}
  1046. X    
  1047. X# compare 2 values returns one of undef, <0, =0, >0
  1048. X#   returns undef if either or both input value are not numbers
  1049. Xsub main'fcmp #(fnum_str, fnum_str) return cond_code
  1050. X{
  1051. X    local($x, $y) = (&'fnorm($_[0]),&'fnorm($_[1]));
  1052. X    if ($x eq "NaN" || $y eq "NaN") {
  1053. X    undef;
  1054. X    } elsif ($x eq $y) {
  1055. X    0;
  1056. X    } elsif (ord($x) != ord($y)) {
  1057. X    (ord($y) - ord($x));                # based on signs
  1058. X    } else {
  1059. X    local($xm,$xe) = split('E',$x);
  1060. X    local($ym,$ye) = split('E',$y);
  1061. X    if ($xe ne $ye) {
  1062. X        ($xe - $ye) * (substr($x,0,1).'1');
  1063. X    } else {
  1064. X        &bigint'cmp($xm,$ym);           # based on value
  1065. X    }
  1066. X    }
  1067. X}
  1068. X
  1069. X# square root by Newtons method.
  1070. Xsub main'fsqrt { #(fnum_str[, scale]) return fnum_str
  1071. X    local($x, $scale) = (&'fnorm($_[0]), $_[1]);
  1072. X    if ($x eq 'NaN' || $x =~ /^-/) {
  1073. X    'NaN';
  1074. X    } elsif ($x eq '+0E+0') {
  1075. X    '+0E+0';
  1076. X    } else {
  1077. X    local($xm, $xe) = split('E',$x);
  1078. X    $scale = $div_scale if (!$scale);
  1079. X    $scale = length($xm)-1 if ($scale < length($xm)-1);
  1080. X    local($gs, $guess) = (1, sprintf("1E%+d", (length($xm)+$xe-1)/2));
  1081. X    while ($gs < 2*$scale) {
  1082. X        $guess = &'fmul(&'fadd($guess,&'fdiv($x,$guess,$gs*2)),".5");
  1083. X        $gs *= 2;
  1084. X    }
  1085. X    &'fround($guess, $scale);
  1086. X    }
  1087. X}
  1088. X
  1089. X1;
  1090. !STUFFY!FUNK!
  1091. echo Extracting x2p/a2p.man
  1092. sed >x2p/a2p.man <<'!STUFFY!FUNK!' -e 's/X//'
  1093. X.rn '' }`
  1094. X''' $Header: a2p.man,v 4.0 91/03/20 01:57:11 lwall Locked $
  1095. X''' 
  1096. X''' $Log:    a2p.man,v $
  1097. X''' Revision 4.0  91/03/20  01:57:11  lwall
  1098. X''' 4.0 baseline.
  1099. X''' 
  1100. X''' Revision 3.0  89/10/18  15:34:22  lwall
  1101. X''' 3.0 baseline
  1102. X''' 
  1103. X''' Revision 2.0.1.1  88/07/11  23:16:25  root
  1104. X''' patch2: changes related to 1985 awk
  1105. X''' 
  1106. X''' Revision 2.0  88/06/05  00:15:36  root
  1107. X''' Baseline version 2.0.
  1108. X''' 
  1109. X''' 
  1110. X.de Sh
  1111. X.br
  1112. X.ne 5
  1113. X.PP
  1114. X\fB\\$1\fR
  1115. X.PP
  1116. X..
  1117. X.de Sp
  1118. X.if t .sp .5v
  1119. X.if n .sp
  1120. X..
  1121. X.de Ip
  1122. X.br
  1123. X.ie \\n.$>=3 .ne \\$3
  1124. X.el .ne 3
  1125. X.IP "\\$1" \\$2
  1126. X..
  1127. X'''
  1128. X'''     Set up \*(-- to give an unbreakable dash;
  1129. X'''     string Tr holds user defined translation string.
  1130. X'''     Bell System Logo is used as a dummy character.
  1131. X'''
  1132. X.tr \(*W-|\(bv\*(Tr
  1133. X.ie n \{\
  1134. X.ds -- \(*W-
  1135. X.if (\n(.H=4u)&(1m=24u) .ds -- \(*W\h'-12u'\(*W\h'-12u'-\" diablo 10 pitch
  1136. X.if (\n(.H=4u)&(1m=20u) .ds -- \(*W\h'-12u'\(*W\h'-8u'-\" diablo 12 pitch
  1137. X.ds L" ""
  1138. X.ds R" ""
  1139. X.ds L' '
  1140. X.ds R' '
  1141. X'br\}
  1142. X.el\{\
  1143. X.ds -- \(em\|
  1144. X.tr \*(Tr
  1145. X.ds L" ``
  1146. X.ds R" ''
  1147. X.ds L' `
  1148. X.ds R' '
  1149. X'br\}
  1150. X.TH A2P 1 LOCAL
  1151. X.SH NAME
  1152. Xa2p - Awk to Perl translator
  1153. X.SH SYNOPSIS
  1154. X.B a2p [options] filename
  1155. X.SH DESCRIPTION
  1156. X.I A2p
  1157. Xtakes an awk script specified on the command line (or from standard input)
  1158. Xand produces a comparable
  1159. X.I perl
  1160. Xscript on the standard output.
  1161. X.Sh "Options"
  1162. XOptions include:
  1163. X.TP 5
  1164. X.B \-D<number>
  1165. Xsets debugging flags.
  1166. X.TP 5
  1167. X.B \-F<character>
  1168. Xtells a2p that this awk script is always invoked with this -F switch.
  1169. X.TP 5
  1170. X.B \-n<fieldlist>
  1171. Xspecifies the names of the input fields if input does not have to be split into
  1172. Xan array.
  1173. XIf you were translating an awk script that processes the password file, you
  1174. Xmight say:
  1175. X.sp
  1176. X    a2p -7 -nlogin.password.uid.gid.gcos.shell.home
  1177. X.sp
  1178. XAny delimiter can be used to separate the field names.
  1179. X.TP 5
  1180. X.B \-<number>
  1181. Xcauses a2p to assume that input will always have that many fields.
  1182. X.Sh "Considerations"
  1183. XA2p cannot do as good a job translating as a human would, but it usually
  1184. Xdoes pretty well.
  1185. XThere are some areas where you may want to examine the perl script produced
  1186. Xand tweak it some.
  1187. XHere are some of them, in no particular order.
  1188. X.PP
  1189. XThere is an awk idiom of putting int() around a string expression to force
  1190. Xnumeric interpretation, even though the argument is always integer anyway.
  1191. XThis is generally unneeded in perl, but a2p can't tell if the argument
  1192. Xis always going to be integer, so it leaves it in.
  1193. XYou may wish to remove it.
  1194. X.PP
  1195. XPerl differentiates numeric comparison from string comparison.
  1196. XAwk has one operator for both that decides at run time which comparison
  1197. Xto do.
  1198. XA2p does not try to do a complete job of awk emulation at this point.
  1199. XInstead it guesses which one you want.
  1200. XIt's almost always right, but it can be spoofed.
  1201. XAll such guesses are marked with the comment \*(L"#???\*(R".
  1202. XYou should go through and check them.
  1203. XYou might want to run at least once with the \-w switch to perl, which
  1204. Xwill warn you if you use == where you should have used eq.
  1205. X.PP
  1206. XPerl does not attempt to emulate the behavior of awk in which nonexistent
  1207. Xarray elements spring into existence simply by being referenced.
  1208. XIf somehow you are relying on this mechanism to create null entries for
  1209. Xa subsequent for...in, they won't be there in perl.
  1210. X.PP
  1211. XIf a2p makes a split line that assigns to a list of variables that looks
  1212. Xlike (Fld1, Fld2, Fld3...) you may want
  1213. Xto rerun a2p using the \-n option mentioned above.
  1214. XThis will let you name the fields throughout the script.
  1215. XIf it splits to an array instead, the script is probably referring to the number
  1216. Xof fields somewhere.
  1217. X.PP
  1218. XThe exit statement in awk doesn't necessarily exit; it goes to the END
  1219. Xblock if there is one.
  1220. XAwk scripts that do contortions within the END block to bypass the block under
  1221. Xsuch circumstances can be simplified by removing the conditional
  1222. Xin the END block and just exiting directly from the perl script.
  1223. X.PP
  1224. XPerl has two kinds of array, numerically-indexed and associative.
  1225. XAwk arrays are usually translated to associative arrays, but if you happen
  1226. Xto know that the index is always going to be numeric you could change
  1227. Xthe {...} to [...].
  1228. XIteration over an associative array is done using the keys() function, but
  1229. Xiteration over a numeric array is NOT.
  1230. XYou might need to modify any loop that is iterating over the array in question.
  1231. X.PP
  1232. XAwk starts by assuming OFMT has the value %.6g.
  1233. XPerl starts by assuming its equivalent, $#, to have the value %.20g.
  1234. XYou'll want to set $# explicitly if you use the default value of OFMT.
  1235. X.PP
  1236. XNear the top of the line loop will be the split operation that is implicit in
  1237. Xthe awk script.
  1238. XThere are times when you can move this down past some conditionals that
  1239. Xtest the entire record so that the split is not done as often.
  1240. X.PP
  1241. XFor aesthetic reasons you may wish to change the array base $[ from 1 back
  1242. Xto perl's default of 0, but remember to change all array subscripts AND
  1243. Xall substr() and index() operations to match.
  1244. X.PP
  1245. XCute comments that say "# Here is a workaround because awk is dumb" are passed
  1246. Xthrough unmodified.
  1247. X.PP
  1248. XAwk scripts are often embedded in a shell script that pipes stuff into and
  1249. Xout of awk.
  1250. XOften the shell script wrapper can be incorporated into the perl script, since
  1251. Xperl can start up pipes into and out of itself, and can do other things that
  1252. Xawk can't do by itself.
  1253. X.PP
  1254. XScripts that refer to the special variables RSTART and RLENGTH can often
  1255. Xbe simplified by referring to the variables $`, $& and $', as long as they
  1256. Xare within the scope of the pattern match that sets them.
  1257. X.PP
  1258. XThe produced perl script may have subroutines defined to deal with awk's
  1259. Xsemantics regarding getline and print.
  1260. XSince a2p usually picks correctness over efficiency.
  1261. Xit is almost always possible to rewrite such code to be more efficient by
  1262. Xdiscarding the semantic sugar.
  1263. X.PP
  1264. XFor efficiency, you may wish to remove the keyword from any return statement
  1265. Xthat is the last statement executed in a subroutine.
  1266. XA2p catches the most common case, but doesn't analyze embedded blocks for
  1267. Xsubtler cases.
  1268. X.PP
  1269. XARGV[0] translates to $ARGV0, but ARGV[n] translates to $ARGV[$n].
  1270. XA loop that tries to iterate over ARGV[0] won't find it.
  1271. X.SH ENVIRONMENT
  1272. XA2p uses no environment variables.
  1273. X.SH AUTHOR
  1274. XLarry Wall <lwall@jpl-devvax.Jpl.Nasa.Gov>
  1275. X.SH FILES
  1276. X.SH SEE ALSO
  1277. Xperl    The perl compiler/interpreter
  1278. X.br
  1279. Xs2p    sed to perl translator
  1280. X.SH DIAGNOSTICS
  1281. X.SH BUGS
  1282. XIt would be possible to emulate awk's behavior in selecting string versus
  1283. Xnumeric operations at run time by inspection of the operands, but it would
  1284. Xbe gross and inefficient.
  1285. XBesides, a2p almost always guesses right.
  1286. X.PP
  1287. XStorage for the awk syntax tree is currently static, and can run out.
  1288. X.rn }` ''
  1289. !STUFFY!FUNK!
  1290. echo Extracting x2p/a2p.h
  1291. sed >x2p/a2p.h <<'!STUFFY!FUNK!' -e 's/X//'
  1292. X/* $Header: a2p.h,v 4.0 91/03/20 01:57:07 lwall Locked $
  1293. X *
  1294. X *    Copyright (c) 1989, Larry Wall
  1295. X *
  1296. X *    You may distribute under the terms of the GNU General Public License
  1297. X *    as specified in the README file that comes with the perl 3.0 kit.
  1298. X *
  1299. X * $Log:    a2p.h,v $
  1300. X * Revision 4.0  91/03/20  01:57:07  lwall
  1301. X * 4.0 baseline.
  1302. X * 
  1303. X */
  1304. X
  1305. X#define VOIDUSED 1
  1306. X#include "../config.h"
  1307. X
  1308. X#ifndef HAS_BCOPY
  1309. X#   define bcopy(s1,s2,l) memcpy(s2,s1,l)
  1310. X#endif
  1311. X#ifndef HAS_BZERO
  1312. X#   define bzero(s,l) memset(s,0,l)
  1313. X#endif
  1314. X
  1315. X#include "handy.h"
  1316. X#define Nullop 0
  1317. X
  1318. X#define OPROG        1
  1319. X#define OJUNK        2
  1320. X#define OHUNKS        3
  1321. X#define ORANGE        4
  1322. X#define OPAT        5
  1323. X#define OHUNK        6
  1324. X#define OPPAREN        7
  1325. X#define OPANDAND    8
  1326. X#define OPOROR        9
  1327. X#define OPNOT        10
  1328. X#define OCPAREN        11
  1329. X#define OCANDAND    12
  1330. X#define OCOROR        13
  1331. X#define OCNOT        14
  1332. X#define ORELOP        15
  1333. X#define ORPAREN        16
  1334. X#define OMATCHOP    17
  1335. X#define OMPAREN        18
  1336. X#define OCONCAT        19
  1337. X#define OASSIGN        20
  1338. X#define OADD        21
  1339. X#define OSUBTRACT    22
  1340. X#define OMULT        23
  1341. X#define ODIV        24
  1342. X#define OMOD        25
  1343. X#define OPOSTINCR    26
  1344. X#define OPOSTDECR    27
  1345. X#define OPREINCR    28
  1346. X#define OPREDECR    29
  1347. X#define OUMINUS        30
  1348. X#define OUPLUS        31
  1349. X#define OPAREN        32
  1350. X#define OGETLINE    33
  1351. X#define OSPRINTF    34
  1352. X#define OSUBSTR        35
  1353. X#define OSTRING        36
  1354. X#define OSPLIT        37
  1355. X#define OSNEWLINE    38
  1356. X#define OINDEX        39
  1357. X#define ONUM        40
  1358. X#define OSTR        41
  1359. X#define OVAR        42
  1360. X#define OFLD        43
  1361. X#define ONEWLINE    44
  1362. X#define OCOMMENT    45
  1363. X#define OCOMMA        46
  1364. X#define OSEMICOLON    47
  1365. X#define OSCOMMENT    48
  1366. X#define OSTATES        49
  1367. X#define OSTATE        50
  1368. X#define OPRINT        51
  1369. X#define OPRINTF        52
  1370. X#define OBREAK        53
  1371. X#define ONEXT        54
  1372. X#define OEXIT        55
  1373. X#define OCONTINUE    56
  1374. X#define OREDIR        57
  1375. X#define OIF        58
  1376. X#define OWHILE        59
  1377. X#define OFOR        60
  1378. X#define OFORIN        61
  1379. X#define OVFLD        62
  1380. X#define OBLOCK        63
  1381. X#define OREGEX        64
  1382. X#define OLENGTH        65
  1383. X#define OLOG        66
  1384. X#define OEXP        67
  1385. X#define OSQRT        68
  1386. X#define OINT        69
  1387. X#define ODO        70
  1388. X#define OPOW        71
  1389. X#define OSUB        72
  1390. X#define OGSUB        73
  1391. X#define OMATCH        74
  1392. X#define OUSERFUN    75
  1393. X#define OUSERDEF    76
  1394. X#define OCLOSE        77
  1395. X#define OATAN2        78
  1396. X#define OSIN        79
  1397. X#define OCOS        80
  1398. X#define ORAND        81
  1399. X#define OSRAND        82
  1400. X#define ODELETE        83
  1401. X#define OSYSTEM        84
  1402. X#define OCOND        85
  1403. X#define ORETURN        86
  1404. X#define ODEFINED    87
  1405. X#define OSTAR        88
  1406. X
  1407. X#ifdef DOINIT
  1408. Xchar *opname[] = {
  1409. X    "0",
  1410. X    "PROG",
  1411. X    "JUNK",
  1412. X    "HUNKS",
  1413. X    "RANGE",
  1414. X    "PAT",
  1415. X    "HUNK",
  1416. X    "PPAREN",
  1417. X    "PANDAND",
  1418. X    "POROR",
  1419. X    "PNOT",
  1420. X    "CPAREN",
  1421. X    "CANDAND",
  1422. X    "COROR",
  1423. X    "CNOT",
  1424. X    "RELOP",
  1425. X    "RPAREN",
  1426. X    "MATCHOP",
  1427. X    "MPAREN",
  1428. X    "CONCAT",
  1429. X    "ASSIGN",
  1430. X    "ADD",
  1431. X    "SUBTRACT",
  1432. X    "MULT",
  1433. X    "DIV",
  1434. X    "MOD",
  1435. X    "POSTINCR",
  1436. X    "POSTDECR",
  1437. X    "PREINCR",
  1438. X    "PREDECR",
  1439. X    "UMINUS",
  1440. X    "UPLUS",
  1441. X    "PAREN",
  1442. X    "GETLINE",
  1443. X    "SPRINTF",
  1444. X    "SUBSTR",
  1445. X    "STRING",
  1446. X    "SPLIT",
  1447. X    "SNEWLINE",
  1448. X    "INDEX",
  1449. X    "NUM",
  1450. X    "STR",
  1451. X    "VAR",
  1452. X    "FLD",
  1453. X    "NEWLINE",
  1454. X    "COMMENT",
  1455. X    "COMMA",
  1456. X    "SEMICOLON",
  1457. X    "SCOMMENT",
  1458. X    "STATES",
  1459. X    "STATE",
  1460. X    "PRINT",
  1461. X    "PRINTF",
  1462. X    "BREAK",
  1463. X    "NEXT",
  1464. X    "EXIT",
  1465. X    "CONTINUE",
  1466. X    "REDIR",
  1467. X    "IF",
  1468. X    "WHILE",
  1469. X    "FOR",
  1470. X    "FORIN",
  1471. X    "VFLD",
  1472. X    "BLOCK",
  1473. X    "REGEX",
  1474. X    "LENGTH",
  1475. X    "LOG",
  1476. X    "EXP",
  1477. X    "SQRT",
  1478. X    "INT",
  1479. X    "DO",
  1480. X    "POW",
  1481. X    "SUB",
  1482. X    "GSUB",
  1483. X    "MATCH",
  1484. X    "USERFUN",
  1485. X    "USERDEF",
  1486. X    "CLOSE",
  1487. X    "ATAN2",
  1488. X    "SIN",
  1489. X    "COS",
  1490. X    "RAND",
  1491. X    "SRAND",
  1492. X    "DELETE",
  1493. X    "SYSTEM",
  1494. X    "COND",
  1495. X    "RETURN",
  1496. X    "DEFINED",
  1497. X    "STAR",
  1498. X    "89"
  1499. X};
  1500. X#else
  1501. Xextern char *opname[];
  1502. X#endif
  1503. X
  1504. XEXT int mop INIT(1);
  1505. X
  1506. Xunion u_ops {
  1507. X    int ival;
  1508. X    char *cval;
  1509. X};
  1510. X#if defined(iAPX286) || defined(M_I286) || defined(I80286)     /* 80286 hack */
  1511. X#define OPSMAX (64000/sizeof(union u_ops))    /* approx. max segment size */
  1512. X#else
  1513. X#define OPSMAX 50000
  1514. X#endif                             /* 80286 hack */
  1515. Xunion u_ops ops[OPSMAX];
  1516. X
  1517. X#include <stdio.h>
  1518. X#include <ctype.h>
  1519. X
  1520. Xtypedef struct string STR;
  1521. Xtypedef struct htbl HASH;
  1522. X
  1523. X#include "str.h"
  1524. X#include "hash.h"
  1525. X
  1526. X/* A string is TRUE if not "" or "0". */
  1527. X#define True(val) (tmps = (val), (*tmps && !(*tmps == '0' && !tmps[1])))
  1528. XEXT char *Yes INIT("1");
  1529. XEXT char *No INIT("");
  1530. X
  1531. X#define str_true(str) (Str = (str), (Str->str_pok ? True(Str->str_ptr) : (Str->str_nok ? (Str->str_nval != 0.0) : 0 )))
  1532. X
  1533. X#define str_peek(str) (Str = (str), (Str->str_pok ? Str->str_ptr : (Str->str_nok ? (sprintf(buf,"num(%g)",Str->str_nval),buf) : "" )))
  1534. X#define str_get(str) (Str = (str), (Str->str_pok ? Str->str_ptr : str_2ptr(Str)))
  1535. X#define str_gnum(str) (Str = (str), (Str->str_nok ? Str->str_nval : str_2num(Str)))
  1536. XEXT STR *Str;
  1537. X
  1538. X#define GROWSTR(pp,lp,len) if (*(lp) < (len)) growstr(pp,lp,len)
  1539. X
  1540. XSTR *str_new();
  1541. X
  1542. Xchar *scanpat();
  1543. Xchar *scannum();
  1544. X
  1545. Xvoid str_free();
  1546. X
  1547. XEXT int line INIT(0);
  1548. X
  1549. XEXT FILE *rsfp;
  1550. XEXT char buf[2048];
  1551. XEXT char *bufptr INIT(buf);
  1552. X
  1553. XEXT STR *linestr INIT(Nullstr);
  1554. X
  1555. XEXT char tokenbuf[2048];
  1556. XEXT int expectterm INIT(TRUE);
  1557. X
  1558. X#ifdef DEBUGGING
  1559. XEXT int debug INIT(0);
  1560. XEXT int dlevel INIT(0);
  1561. X#define YYDEBUG 1
  1562. Xextern int yydebug;
  1563. X#endif
  1564. X
  1565. XEXT STR *freestrroot INIT(Nullstr);
  1566. X
  1567. XEXT STR str_no;
  1568. XEXT STR str_yes;
  1569. X
  1570. XEXT bool do_split INIT(FALSE);
  1571. XEXT bool split_to_array INIT(FALSE);
  1572. XEXT bool set_array_base INIT(FALSE);
  1573. XEXT bool saw_RS INIT(FALSE);
  1574. XEXT bool saw_OFS INIT(FALSE);
  1575. XEXT bool saw_ORS INIT(FALSE);
  1576. XEXT bool saw_line_op INIT(FALSE);
  1577. XEXT bool in_begin INIT(TRUE);
  1578. XEXT bool do_opens INIT(FALSE);
  1579. XEXT bool do_fancy_opens INIT(FALSE);
  1580. XEXT bool lval_field INIT(FALSE);
  1581. XEXT bool do_chop INIT(FALSE);
  1582. XEXT bool need_entire INIT(FALSE);
  1583. XEXT bool absmaxfld INIT(FALSE);
  1584. XEXT bool saw_altinput INIT(FALSE);
  1585. X
  1586. XEXT char const_FS INIT(0);
  1587. XEXT char *namelist INIT(Nullch);
  1588. XEXT char fswitch INIT(0);
  1589. X
  1590. XEXT int saw_FS INIT(0);
  1591. XEXT int maxfld INIT(0);
  1592. XEXT int arymax INIT(0);
  1593. Xchar *nameary[100];
  1594. X
  1595. XEXT STR *opens;
  1596. X
  1597. XEXT HASH *symtab;
  1598. XEXT HASH *curarghash;
  1599. X
  1600. X#define P_MIN        0
  1601. X#define P_LISTOP    5
  1602. X#define P_COMMA        10
  1603. X#define P_ASSIGN    15
  1604. X#define P_COND        20
  1605. X#define P_DOTDOT    25
  1606. X#define P_OROR        30
  1607. X#define P_ANDAND    35
  1608. X#define P_OR        40
  1609. X#define P_AND        45
  1610. X#define P_EQ        50
  1611. X#define P_REL        55
  1612. X#define P_UNI        60
  1613. X#define P_FILETEST    65
  1614. X#define P_SHIFT        70
  1615. X#define P_ADD        75
  1616. X#define P_MUL        80
  1617. X#define P_MATCH        85
  1618. X#define P_UNARY        90
  1619. X#define P_POW        95
  1620. X#define P_AUTO        100
  1621. X#define P_MAX        999
  1622. !STUFFY!FUNK!
  1623. echo Extracting os2/suffix.c
  1624. sed >os2/suffix.c <<'!STUFFY!FUNK!' -e 's/X//'
  1625. X/*
  1626. X * Suffix appending for in-place editing under MS-DOS and OS/2.
  1627. X *
  1628. X * Here are the rules:
  1629. X *
  1630. X * Style 0:  Append the suffix exactly as standard perl would do it.
  1631. X *           If the filesystem groks it, use it.  (HPFS will always
  1632. X *           grok it.  FAT will rarely accept it.)
  1633. X *
  1634. X * Style 1:  The suffix begins with a '.'.  The extension is replaced.
  1635. X *           If the name matches the original name, use the fallback method.
  1636. X *
  1637. X * Style 2:  The suffix is a single character, not a '.'.  Try to add the 
  1638. X *           suffix to the following places, using the first one that works.
  1639. X *               [1] Append to extension.  
  1640. X *               [2] Append to filename, 
  1641. X *               [3] Replace end of extension, 
  1642. X *               [4] Replace end of filename.
  1643. X *           If the name matches the original name, use the fallback method.
  1644. X *
  1645. X * Style 3:  Any other case:  Ignore the suffix completely and use the
  1646. X *           fallback method.
  1647. X *
  1648. X * Fallback method:  Change the extension to ".$$$".  If that matches the
  1649. X *           original name, then change the extension to ".~~~".
  1650. X *
  1651. X * If filename is more than 1000 characters long, we die a horrible
  1652. X * death.  Sorry.
  1653. X *
  1654. X * The filename restriction is a cheat so that we can use buf[] to store
  1655. X * assorted temporary goo.
  1656. X *
  1657. X * Examples, assuming style 0 failed.
  1658. X *
  1659. X * suffix = ".bak" (style 1)
  1660. X *                foo.bar => foo.bak
  1661. X *                foo.bak => foo.$$$    (fallback)
  1662. X *                foo.$$$ => foo.~~~    (fallback)
  1663. X *                makefile => makefile.bak
  1664. X *
  1665. X * suffix = "~" (style 2)
  1666. X *                foo.c => foo.c~
  1667. X *                foo.c~ => foo.c~~
  1668. X *                foo.c~~ => foo~.c~~
  1669. X *                foo~.c~~ => foo~~.c~~
  1670. X *                foo~~~~~.c~~ => foo~~~~~.$$$ (fallback)
  1671. X *
  1672. X *                foo.pas => foo~.pas
  1673. X *                makefile => makefile.~
  1674. X *                longname.fil => longname.fi~
  1675. X *                longname.fi~ => longnam~.fi~
  1676. X *                longnam~.fi~ => longnam~.$$$
  1677. X *                
  1678. X */
  1679. X
  1680. X#include "EXTERN.h"
  1681. X#include "perl.h"
  1682. X#ifdef OS2
  1683. X#define INCL_DOSFILEMGR
  1684. X#define INCL_DOSERRORS
  1685. X#include <os2.h>
  1686. X#endif /* OS2 */
  1687. X
  1688. Xstatic char suffix1[] = ".$$$";
  1689. Xstatic char suffix2[] = ".~~~";
  1690. X
  1691. X#define ext (&buf[1000])
  1692. X
  1693. Xadd_suffix(str,suffix)
  1694. Xregister STR *str;
  1695. Xregister char *suffix;
  1696. X{
  1697. X    int baselen;
  1698. X    int extlen;
  1699. X    char *s, *t, *p;
  1700. X    STRLEN slen;
  1701. X
  1702. X    if (!(str->str_pok)) (void)str_2ptr(str);
  1703. X    if (str->str_cur > 1000)
  1704. X        fatal("Cannot do inplace edit on long filename (%d characters)", str->str_cur);
  1705. X
  1706. X#ifdef OS2
  1707. X    /* Style 0 */
  1708. X    slen = str->str_cur;
  1709. X    str_cat(str, suffix);
  1710. X    if (valid_filename(str->str_ptr)) return;
  1711. X
  1712. X    /* Fooey, style 0 failed.  Fix str before continuing. */
  1713. X    str->str_ptr[str->str_cur = slen] = '\0';
  1714. X#endif /* OS2 */
  1715. X
  1716. X    slen = strlen(suffix);
  1717. X    t = buf; baselen = 0; s = str->str_ptr;
  1718. X    while ( (*t = *s) && *s != '.') {
  1719. X    baselen++;
  1720. X    if (*s == '\\' || *s == '/') baselen = 0;
  1721. X     s++; t++;
  1722. X    }
  1723. X    p = t;
  1724. X
  1725. X    t = ext; extlen = 0;
  1726. X    while (*t++ = *s++) extlen++;
  1727. X    if (extlen == 0) { ext[0] = '.'; ext[1] = 0; extlen++; }
  1728. X
  1729. X    if (*suffix == '.') {        /* Style 1 */
  1730. X        if (strEQ(ext, suffix)) goto fallback;
  1731. X    strcpy(p, suffix);
  1732. X    } else if (suffix[1] == '\0') {  /* Style 2 */
  1733. X        if (extlen < 4) { 
  1734. X        ext[extlen] = *suffix;
  1735. X        ext[++extlen] = '\0';
  1736. X        } else if (baselen < 8) {
  1737. X           *p++ = *suffix;
  1738. X    } else if (ext[3] != *suffix) {
  1739. X        ext[3] = *suffix;
  1740. X    } else if (buf[7] != *suffix) {
  1741. X        buf[7] = *suffix;
  1742. X    } else goto fallback;
  1743. X    strcpy(p, ext);
  1744. X    } else { /* Style 3:  Panic */
  1745. Xfallback:
  1746. X    (void)bcopy(strEQ(ext, suffix1) ? suffix2 : suffix1, p, 4+1);
  1747. X    }
  1748. X    str_set(str, buf);
  1749. X}
  1750. X
  1751. X#ifdef OS2
  1752. Xint 
  1753. Xvalid_filename(s)
  1754. Xchar *s;
  1755. X{
  1756. X    HFILE hf;
  1757. X    USHORT usAction;
  1758. X
  1759. X    switch(DosOpen(s, &hf, &usAction, 0L, 0, FILE_OPEN,
  1760. X    OPEN_ACCESS_READONLY | OPEN_SHARE_DENYNONE, 0L)) {
  1761. X    case ERROR_INVALID_NAME:
  1762. X    case ERROR_FILENAME_EXCED_RANGE:
  1763. X    return 0;
  1764. X    case NO_ERROR:
  1765. X    DosClose(hf);
  1766. X    /*FALLTHROUGH*/
  1767. X    default:
  1768. X    return 1;
  1769. X    }
  1770. X}
  1771. X#endif /* OS2 */
  1772. !STUFFY!FUNK!
  1773. echo " "
  1774. echo "End of kit 29 (of 36)"
  1775. cat /dev/null >kit29isdone
  1776. run=''
  1777. config=''
  1778. 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
  1779.     if test -f kit${iskit}isdone; then
  1780.     run="$run $iskit"
  1781.     else
  1782.     todo="$todo $iskit"
  1783.     fi
  1784. done
  1785. case $todo in
  1786.     '')
  1787.     echo "You have run all your kits.  Please read README and then type Configure."
  1788.     for combo in *:AA; do
  1789.         if test -f "$combo"; then
  1790.         realfile=`basename $combo :AA`
  1791.         cat $realfile:[A-Z][A-Z] >$realfile
  1792.         rm -rf $realfile:[A-Z][A-Z]
  1793.         fi
  1794.     done
  1795.     rm -rf kit*isdone
  1796.     chmod 755 Configure
  1797.     ;;
  1798.     *)  echo "You have run$run."
  1799.     echo "You still need to run$todo."
  1800.     ;;
  1801. esac
  1802. : Someone might mail this, so...
  1803. exit
  1804.  
  1805. exit 0 # Just in case...
  1806. -- 
  1807. Kent Landfield                   INTERNET: kent@sparky.IMD.Sterling.COM
  1808. Sterling Software, IMD           UUCP:     uunet!sparky!kent
  1809. Phone:    (402) 291-8300         FAX:      (402) 291-4362
  1810. Please send comp.sources.misc-related mail to kent@uunet.uu.net.
  1811.