home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1994 October / usenetsourcesnewsgroupsinfomagicoctober1994disk2.iso / unix / volume20 / perl3.0 / part18 < prev    next >
Encoding:
Internet Message Format  |  1989-11-01  |  49.1 KB
  1. Subject:  v20i101:  Perl, a language with features of C/sed/awk/sehll/etc, Part18/24
  2. Newsgroups: comp.sources.unix
  3. Sender: sources
  4. Approved: rsalz@uunet.UU.NET
  5.  
  6. Submitted-by: Larry Wall <lwall@jpl-devvax.jpl.nasa.gov>
  7. Posting-number: Volume 20, Issue 101
  8. Archive-name: perl3.0/part18
  9.  
  10. #! /bin/sh
  11.  
  12. # Make a new directory for the perl sources, cd to it, and run kits 1
  13. # thru 24 through sh.  When all 24 kits have been run, read README.
  14.  
  15. echo "This is perl 3.0 kit 18 (of 24).  If kit 18 is complete, the line"
  16. echo '"'"End of kit 18 (of 24)"'" will echo at the end.'
  17. echo ""
  18. export PATH || (echo "You didn't use sh, you clunch." ; kill $$)
  19. mkdir lib t x2p 2>/dev/null
  20. echo Extracting x2p/s2p.SH
  21. sed >x2p/s2p.SH <<'!STUFFY!FUNK!' -e 's/X//'
  22. X: This forces SH files to create target in same directory as SH file.
  23. X: This is so that make depend always knows where to find SH derivatives.
  24. Xcase "$0" in
  25. X*/*) cd `expr X$0 : 'X\(.*\)/'` ;;
  26. Xesac
  27. Xcase $CONFIG in
  28. X'')
  29. X    if test ! -f config.sh; then
  30. X    ln ../config.sh . || \
  31. X    ln ../../config.sh . || \
  32. X    ln ../../../config.sh . || \
  33. X    (echo "Can't find config.sh."; exit 1)
  34. X    fi
  35. X    . config.sh
  36. X    ;;
  37. Xesac
  38. Xecho "Extracting s2p (with variable substitutions)"
  39. X: This section of the file will have variable substitutions done on it.
  40. X: Move anything that needs config subs from !NO!SUBS! section to !GROK!THIS!.
  41. X: Protect any dollar signs and backticks that you do not want interpreted
  42. X: by putting a backslash in front.  You may delete these comments.
  43. X$spitshell >s2p <<!GROK!THIS!
  44. X#!$bin/perl
  45. X
  46. X\$bin = '$bin';
  47. X!GROK!THIS!
  48. X
  49. X: In the following dollars and backticks do not need the extra backslash.
  50. X$spitshell >>s2p <<'!NO!SUBS!'
  51. X
  52. X# $Header: s2p.SH,v 3.0 89/10/18 15:35:02 lwall Locked $
  53. X#
  54. X# $Log:    s2p.SH,v $
  55. X# Revision 3.0  89/10/18  15:35:02  lwall
  56. X# 3.0 baseline
  57. X# 
  58. X# Revision 2.0.1.1  88/07/11  23:26:23  root
  59. X# patch2: s2p didn't put a proper prologue on output script
  60. X# 
  61. X# Revision 2.0  88/06/05  00:15:55  root
  62. X# Baseline version 2.0.
  63. X# 
  64. X#
  65. X
  66. X$indent = 4;
  67. X$shiftwidth = 4;
  68. X$l = '{'; $r = '}';
  69. X$tempvar = '1';
  70. X
  71. Xwhile ($ARGV[0] =~ '^-') {
  72. X    $_ = shift;
  73. X  last if /^--/;
  74. X    if (/^-D/) {
  75. X    $debug++;
  76. X    open(body,'>-');
  77. X    next;
  78. X    }
  79. X    if (/^-n/) {
  80. X    $assumen++;
  81. X    next;
  82. X    }
  83. X    if (/^-p/) {
  84. X    $assumep++;
  85. X    next;
  86. X    }
  87. X    die "I don't recognize this switch: $_\n";
  88. X}
  89. X
  90. Xunless ($debug) {
  91. X    open(body,">/tmp/sperl$$") || do Die("Can't open temp file");
  92. X}
  93. X
  94. Xif (!$assumen && !$assumep) {
  95. X    print body
  96. X'while ($ARGV[0] =~ /^-/) {
  97. X    $_ = shift;
  98. X  last if /^--/;
  99. X    if (/^-n/) {
  100. X    $nflag++;
  101. X    next;
  102. X    }
  103. X    die "I don\'t recognize this switch: $_\\n";
  104. X}
  105. X
  106. X';
  107. X}
  108. X
  109. Xprint body '
  110. X#ifdef PRINTIT
  111. X#ifdef ASSUMEP
  112. X$printit++;
  113. X#else
  114. X$printit++ unless $nflag;
  115. X#endif
  116. X#endif
  117. Xline: while (<>) {
  118. X';
  119. X
  120. Xline: while (<>) {
  121. X    s/[ \t]*(.*)\n$/$1/;
  122. X    if (/^:/) {
  123. X    s/^:[ \t]*//;
  124. X    $label = do make_label($_);
  125. X    if ($. == 1) {
  126. X        $toplabel = $label;
  127. X    }
  128. X    $_ = "$label:";
  129. X    if ($lastlinewaslabel++) {$_ .= "\t;";}
  130. X    if ($indent >= 2) {
  131. X        $indent -= 2;
  132. X        $indmod = 2;
  133. X    }
  134. X    next;
  135. X    } else {
  136. X    $lastlinewaslabel = '';
  137. X    }
  138. X    $addr1 = '';
  139. X    $addr2 = '';
  140. X    if (s/^([0-9]+)//) {
  141. X    $addr1 = "$1";
  142. X    }
  143. X    elsif (s/^\$//) {
  144. X    $addr1 = 'eof()';
  145. X    }
  146. X    elsif (s|^/||) {
  147. X    $addr1 = do fetchpat('/');
  148. X    }
  149. X    if (s/^,//) {
  150. X    if (s/^([0-9]+)//) {
  151. X        $addr2 = "$1";
  152. X    } elsif (s/^\$//) {
  153. X        $addr2 = "eof()";
  154. X    } elsif (s|^/||) {
  155. X        $addr2 = do fetchpat('/');
  156. X    } else {
  157. X        do Die("Invalid second address at line $.\n");
  158. X    }
  159. X    $addr1 .= " .. $addr2";
  160. X    }
  161. X                    # a { to keep vi happy
  162. X    s/^[ \t]+//;
  163. X    if ($_ eq '}') {
  164. X    $indent -= 4;
  165. X    next;
  166. X    }
  167. X    if (s/^!//) {
  168. X    $if = 'unless';
  169. X    $else = "$r else $l\n";
  170. X    } else {
  171. X    $if = 'if';
  172. X    $else = '';
  173. X    }
  174. X    if (s/^{//) {    # a } to keep vi happy
  175. X    $indmod = 4;
  176. X    $redo = $_;
  177. X    $_ = '';
  178. X    $rmaybe = '';
  179. X    } else {
  180. X    $rmaybe = "\n$r";
  181. X    if ($addr2 || $addr1) {
  182. X        $space = ' ' x $shiftwidth;
  183. X    } else {
  184. X        $space = '';
  185. X    }
  186. X    $_ = do transmogrify();
  187. X    }
  188. X
  189. X    if ($addr1) {
  190. X    if ($_ !~ /[\n{}]/ && $rmaybe && !$change &&
  191. X      $_ !~ / if / && $_ !~ / unless /) {
  192. X        s/;$/ $if $addr1;/;
  193. X        $_ = substr($_,$shiftwidth,1000);
  194. X    } else {
  195. X        $command = $_;
  196. X        $_ = "$if ($addr1) $l\n$change$command$rmaybe";
  197. X    }
  198. X    $change = '';
  199. X    next line;
  200. X    }
  201. X} continue {
  202. X    @lines = split(/\n/,$_);
  203. X    while ($#lines >= 0) {
  204. X    $_ = shift(lines);
  205. X    unless (s/^ *<<--//) {
  206. X        print body "\t" x ($indent / 8), ' ' x ($indent % 8);
  207. X    }
  208. X    print body $_, "\n";
  209. X    }
  210. X    $indent += $indmod;
  211. X    $indmod = 0;
  212. X    if ($redo) {
  213. X    $_ = $redo;
  214. X    $redo = '';
  215. X    redo line;
  216. X    }
  217. X}
  218. X
  219. Xprint body "}\n";
  220. Xif ($appendseen || $tseen || !$assumen) {
  221. X    $printit++ if $dseen || (!$assumen && !$assumep);
  222. X    print body '
  223. Xcontinue {
  224. X#ifdef PRINTIT
  225. X#ifdef DSEEN
  226. X#ifdef ASSUMEP
  227. X    print if $printit++;
  228. X#else
  229. X    if ($printit) { print;} else { $printit++ unless $nflag; }
  230. X#endif
  231. X#else
  232. X    print if $printit;
  233. X#endif
  234. X#else
  235. X    print;
  236. X#endif
  237. X#ifdef TSEEN
  238. X    $tflag = \'\';
  239. X#endif
  240. X#ifdef APPENDSEEN
  241. X    if ($atext) { print $atext; $atext = \'\'; }
  242. X#endif
  243. X}
  244. X';
  245. X}
  246. X
  247. Xclose body;
  248. X
  249. Xunless ($debug) {
  250. X    open(head,">/tmp/sperl2$$.c") || do Die("Can't open temp file 2");
  251. X    print head "#define PRINTIT\n" if ($printit);
  252. X    print head "#define APPENDSEEN\n" if ($appendseen);
  253. X    print head "#define TSEEN\n" if ($tseen);
  254. X    print head "#define DSEEN\n" if ($dseen);
  255. X    print head "#define ASSUMEN\n" if ($assumen);
  256. X    print head "#define ASSUMEP\n" if ($assumep);
  257. X    if ($opens) {print head "$opens\n";}
  258. X    open(body,"/tmp/sperl$$") || do Die("Can't reopen temp file");
  259. X    while (<body>) {
  260. X    print head $_;
  261. X    }
  262. X    close head;
  263. X
  264. X    print "#!$bin/perl
  265. Xeval \"exec $bin/perl -S \$0 \$*\"
  266. X    if \$running_under_some_shell;
  267. X
  268. X";
  269. X    open(body,"cc -E /tmp/sperl2$$.c |") ||
  270. X    do Die("Can't reopen temp file");
  271. X    while (<body>) {
  272. X    /^# [0-9]/ && next;
  273. X    /^[ \t]*$/ && next;
  274. X    s/^<><>//;
  275. X    print;
  276. X    }
  277. X}
  278. X
  279. Xunlink "/tmp/sperl$$", "/tmp/sperl2$$";
  280. X
  281. Xsub Die {
  282. X    unlink "/tmp/sperl$$", "/tmp/sperl2$$";
  283. X    die $_[0];
  284. X}
  285. Xsub make_filehandle {
  286. X    $fname = $_ = $_[0];
  287. X    s/[^a-zA-Z]/_/g;
  288. X    s/^_*//;
  289. X    if (/^([a-z])([a-z]*)$/) {
  290. X    $first = $1;
  291. X    $rest = $2;
  292. X    $first =~ y/a-z/A-Z/;
  293. X    $_ = $first . $rest;
  294. X    }
  295. X    if (!$seen{$_}) {
  296. X    $opens .= "open($_,'>$fname') || die \"Can't create $fname\";\n";
  297. X    }
  298. X    $seen{$_} = $_;
  299. X}
  300. X
  301. Xsub make_label {
  302. X    $label = $_[0];
  303. X    $label =~ s/[^a-zA-Z0-9]/_/g;
  304. X    if ($label =~ /^[0-9_]/) { $label = 'L' . $label; }
  305. X    $label = substr($label,0,8);
  306. X    if ($label =~ /^([a-z])([a-z]*)$/) {    # could be reserved word
  307. X    $first = $1;
  308. X    $rest = $2;
  309. X    $first =~ y/a-z/A-Z/;            # so capitalize it
  310. X    $label = $first . $rest;
  311. X    }
  312. X    $label;
  313. X}
  314. X
  315. Xsub transmogrify {
  316. X    {    # case
  317. X    if (/^d/) {
  318. X        $dseen++;
  319. X        $_ = '
  320. X<<--#ifdef PRINTIT
  321. X$printit = \'\';
  322. X<<--#endif
  323. Xnext line;';
  324. X        next;
  325. X    }
  326. X
  327. X    if (/^n/) {
  328. X        $_ =
  329. X'<<--#ifdef PRINTIT
  330. X<<--#ifdef DSEEN
  331. X<<--#ifdef ASSUMEP
  332. Xprint if $printit++;
  333. X<<--#else
  334. Xif ($printit) { print;} else { $printit++ unless $nflag; }
  335. X<<--#endif
  336. X<<--#else
  337. Xprint if $printit;
  338. X<<--#endif
  339. X<<--#else
  340. Xprint;
  341. X<<--#endif
  342. X<<--#ifdef APPENDSEEN
  343. Xif ($atext) {print $atext; $atext = \'\';}
  344. X<<--#endif
  345. X$_ = <>;
  346. X<<--#ifdef TSEEN
  347. X$tflag = \'\';
  348. X<<--#endif';
  349. X        next;
  350. X    }
  351. X
  352. X    if (/^a/) {
  353. X        $appendseen++;
  354. X        $command = $space .  '$atext .=' . "\n<<--'";
  355. X        $lastline = 0;
  356. X        while (<>) {
  357. X        s/^[ \t]*//;
  358. X        s/^[\\]//;
  359. X        unless (s|\\$||) { $lastline = 1;}
  360. X        s/'/\\'/g;
  361. X        s/^([ \t]*\n)/<><>$1/;
  362. X        $command .= $_;
  363. X        $command .= '<<--';
  364. X        last if $lastline;
  365. X        }
  366. X        $_ = $command . "';";
  367. X        last;
  368. X    }
  369. X
  370. X    if (/^[ic]/) {
  371. X        if (/^c/) { $change = 1; }
  372. X        $addr1 = '$iter = (' . $addr1 . ')';
  373. X        $command = $space .  'if ($iter == 1) { print' . "\n<<--'";
  374. X        $lastline = 0;
  375. X        while (<>) {
  376. X        s/^[ \t]*//;
  377. X        s/^[\\]//;
  378. X        unless (s/\\$//) { $lastline = 1;}
  379. X        s/'/\\'/g;
  380. X        s/^([ \t]*\n)/<><>$1/;
  381. X        $command .= $_;
  382. X        $command .= '<<--';
  383. X        last if $lastline;
  384. X        }
  385. X        $_ = $command . "';}";
  386. X        if ($change) {
  387. X        $dseen++;
  388. X        $change = "$_\n";
  389. X        $_ = "
  390. X<<--#ifdef PRINTIT
  391. X$space\$printit = '';
  392. X<<--#endif
  393. X${space}next line;";
  394. X        }
  395. X        last;
  396. X    }
  397. X
  398. X    if (/^s/) {
  399. X        $delim = substr($_,1,1);
  400. X        $len = length($_);
  401. X        $repl = $end = 0;
  402. X        $inbracket = 0;
  403. X        for ($i = 2; $i < $len; $i++) {
  404. X        $c = substr($_,$i,1);
  405. X        if ($c eq $delim) {
  406. X            if ($inbracket) {
  407. X            $_ = substr($_,0,$i) . '\\' . substr($_,$i,10000);
  408. X            $i++;
  409. X            $len++;
  410. X            }
  411. X            else {
  412. X            if ($repl) {
  413. X                $end = $i;
  414. X                last;
  415. X            } else {
  416. X                $repl = $i;
  417. X            }
  418. X            }
  419. X        }
  420. X        elsif ($c eq '\\') {
  421. X            $i++;
  422. X            if ($i >= $len) {
  423. X            $_ .= 'n';
  424. X            $_ .= <>;
  425. X            $len = length($_);
  426. X            $_ = substr($_,0,--$len);
  427. X            }
  428. X            elsif (!$repl && substr($_,$i,1) =~ /^[(){}\w]$/) {
  429. X            $i--;
  430. X            $len--;
  431. X            $_ = substr($_,0,$i) . substr($_,$i+1,10000);
  432. X            }
  433. X        }
  434. X        elsif ($c eq '[' && !$repl) {
  435. X            $i++ if substr($_,$i,1) eq '^';
  436. X            $i++ if substr($_,$i,1) eq ']';
  437. X            $inbracket = 1;
  438. X        }
  439. X        elsif ($c eq ']') {
  440. X            $inbracket = 0;
  441. X        }
  442. X        elsif (!$repl && index("()",$c) >= 0) {
  443. X            $_ = substr($_,0,$i) . '\\' . substr($_,$i,10000);
  444. X            $i++;
  445. X            $len++;
  446. X        }
  447. X        }
  448. X        do Die("Malformed substitution at line $.\n") unless $end;
  449. X        $pat = substr($_, 0, $repl + 1);
  450. X        $repl = substr($_, $repl + 1, $end - $repl - 1);
  451. X        $end = substr($_, $end + 1, 1000);
  452. X        $dol = '$';
  453. X        $repl =~ s/\$/\\$/;
  454. X        $repl =~ s'&'$&'g;
  455. X        $repl =~ s/[\\]([0-9])/$dol$1/g;
  456. X        $subst = "$pat$repl$delim";
  457. X        $cmd = '';
  458. X        while ($end) {
  459. X        if ($end =~ s/^g//) { $subst .= 'g'; next; }
  460. X        if ($end =~ s/^p//) { $cmd .= ' && (print)'; next; }
  461. X        if ($end =~ s/^w[ \t]*//) {
  462. X            $fh = do make_filehandle($end);
  463. X            $cmd .= " && (print $fh \$_)";
  464. X            $end = '';
  465. X            next;
  466. X        }
  467. X        do Die("Unrecognized substitution command ($end) at line $.\n");
  468. X        }
  469. X        $_ =
  470. X"<<--#ifdef TSEEN
  471. X$subst && \$tflag++$cmd;
  472. X<<--#else
  473. X$subst$cmd;
  474. X<<--#endif";
  475. X        next;
  476. X    }
  477. X
  478. X    if (/^p/) {
  479. X        $_ = 'print;';
  480. X        next;
  481. X    }
  482. X
  483. X    if (/^w/) {
  484. X        s/^w[ \t]*//;
  485. X        $fh = do make_filehandle($_);
  486. X        $_ = "print $fh \$_;";
  487. X        next;
  488. X    }
  489. X
  490. X    if (/^r/) {
  491. X        $appendseen++;
  492. X        s/^r[ \t]*//;
  493. X        $file = $_;
  494. X        $_ = "\$atext .= `cat $file 2>/dev/null`;";
  495. X        next;
  496. X    }
  497. X
  498. X    if (/^P/) {
  499. X        $_ = 'print $1 if /(^.*\n)/;';
  500. X        next;
  501. X    }
  502. X
  503. X    if (/^D/) {
  504. X        $_ =
  505. X's/^.*\n//;
  506. Xredo line if $_;
  507. Xnext line;';
  508. X        next;
  509. X    }
  510. X
  511. X    if (/^N/) {
  512. X        $_ = '
  513. X$_ .= <>;
  514. X<<--#ifdef TSEEN
  515. X$tflag = \'\';
  516. X<<--#endif';
  517. X        next;
  518. X    }
  519. X
  520. X    if (/^h/) {
  521. X        $_ = '$hold = $_;';
  522. X        next;
  523. X    }
  524. X
  525. X    if (/^H/) {
  526. X        $_ = '$hold .= $_ ? $_ : "\n";';
  527. X        next;
  528. X    }
  529. X
  530. X    if (/^g/) {
  531. X        $_ = '$_ = $hold;';
  532. X        next;
  533. X    }
  534. X
  535. X    if (/^G/) {
  536. X        $_ = '$_ .= $hold ? $hold : "\n";';
  537. X        next;
  538. X    }
  539. X
  540. X    if (/^x/) {
  541. X        $_ = '($_, $hold) = ($hold, $_);';
  542. X        next;
  543. X    }
  544. X
  545. X    if (/^b$/) {
  546. X        $_ = 'next line;';
  547. X        next;
  548. X    }
  549. X
  550. X    if (/^b/) {
  551. X        s/^b[ \t]*//;
  552. X        $lab = do make_label($_);
  553. X        if ($lab eq $toplabel) {
  554. X        $_ = 'redo line;';
  555. X        } else {
  556. X        $_ = "goto $lab;";
  557. X        }
  558. X        next;
  559. X    }
  560. X
  561. X    if (/^t$/) {
  562. X        $_ = 'next line if $tflag;';
  563. X        $tseen++;
  564. X        next;
  565. X    }
  566. X
  567. X    if (/^t/) {
  568. X        s/^t[ \t]*//;
  569. X        $lab = do make_label($_);
  570. X        if ($lab eq $toplabel) {
  571. X        $_ = 'if ($tflag) {$tflag = \'\'; redo line;}';
  572. X        } else {
  573. X        $_ = "if (\$tflag) {\$tflag = ''; goto $lab;}";
  574. X        }
  575. X        $tseen++;
  576. X        next;
  577. X    }
  578. X
  579. X    if (/^=/) {
  580. X        $_ = 'print "$.\n";';
  581. X        next;
  582. X    }
  583. X
  584. X    if (/^q/) {
  585. X        $_ =
  586. X'close(ARGV);
  587. X@ARGV = ();
  588. Xnext line;';
  589. X        next;
  590. X    }
  591. X    } continue {
  592. X    if ($space) {
  593. X        s/^/$space/;
  594. X        s/(\n)(.)/$1$space$2/g;
  595. X    }
  596. X    last;
  597. X    }
  598. X    $_;
  599. X}
  600. X
  601. Xsub fetchpat {
  602. X    local($outer) = @_;
  603. X    local($addr) = $outer;
  604. X    local($inbracket);
  605. X    local($prefix,$delim,$ch);
  606. X
  607. X    delim: while (s:^([^\](|)[\\/]*)([](|)[\\/])::) {
  608. X    $prefix = $1;
  609. X    $delim = $2;
  610. X    print "$prefix\t$delim\t$_\n";
  611. X    if ($delim eq '\\') {
  612. X        s/(.)//;
  613. X        $ch = $1;
  614. X        $delim = '' if $ch =~ /^[(){}\w]$/;
  615. X        $delim .= $1;
  616. X    }
  617. X    elsif ($delim eq '[') {
  618. X        $inbracket = 1;
  619. X        s/^\^// && ($delim .= '^');
  620. X        s/^]// && ($delim .= ']');
  621. X        print "$prefix\t$delim\t$_\n";
  622. X    }
  623. X    elsif ($delim eq ']') {
  624. X        $inbracket = 0;
  625. X    }
  626. X    elsif ($inbracket || $delim ne $outer) {
  627. X        print "Adding\n";
  628. X        $delim = '\\' . $delim;
  629. X    }
  630. X    $addr .= $prefix;
  631. X    $addr .= $delim;
  632. X    if ($delim eq $outer && !$inbracket) {
  633. X        last delim;
  634. X    }
  635. X    }
  636. X    $addr;
  637. X}
  638. X
  639. X!NO!SUBS!
  640. Xchmod 755 s2p
  641. X$eunicefix s2p
  642. !STUFFY!FUNK!
  643. echo Extracting hash.c
  644. sed >hash.c <<'!STUFFY!FUNK!' -e 's/X//'
  645. X/* $Header: hash.c,v 3.0 89/10/18 15:18:32 lwall Locked $
  646. X *
  647. X *    Copyright (c) 1989, Larry Wall
  648. X *
  649. X *    You may distribute under the terms of the GNU General Public License
  650. X *    as specified in the README file that comes with the perl 3.0 kit.
  651. X *
  652. X * $Log:    hash.c,v $
  653. X * Revision 3.0  89/10/18  15:18:32  lwall
  654. X * 3.0 baseline
  655. X * 
  656. X */
  657. X
  658. X#include "EXTERN.h"
  659. X#include "perl.h"
  660. X#include <errno.h>
  661. X
  662. Xextern int errno;
  663. X
  664. XSTR *
  665. Xhfetch(tb,key,klen,lval)
  666. Xregister HASH *tb;
  667. Xchar *key;
  668. Xint klen;
  669. Xint lval;
  670. X{
  671. X    register char *s;
  672. X    register int i;
  673. X    register int hash;
  674. X    register HENT *entry;
  675. X    register int maxi;
  676. X    STR *str;
  677. X#ifdef SOME_DBM
  678. X    datum dkey,dcontent;
  679. X#endif
  680. X
  681. X    if (!tb)
  682. X    return Nullstr;
  683. X
  684. X    /* The hash function we use on symbols has to be equal to the first
  685. X     * character when taken modulo 128, so that str_reset() can be implemented
  686. X     * efficiently.  We throw in the second character and the last character
  687. X     * (times 128) so that long chains of identifiers starting with the
  688. X     * same letter don't have to be strEQ'ed within hfetch(), since it
  689. X     * compares hash values before trying strEQ().
  690. X     */
  691. X    if (!tb->tbl_coeffsize)
  692. X    hash = *key + 128 * key[1] + 128 * key[klen-1];    /* assuming klen > 0 */
  693. X    else {    /* use normal coefficients */
  694. X    if (klen < tb->tbl_coeffsize)
  695. X        maxi = klen;
  696. X    else
  697. X        maxi = tb->tbl_coeffsize;
  698. X    for (s=key,        i=0,    hash = 0;
  699. X                i < maxi;
  700. X         s++,        i++,    hash *= 5) {
  701. X        hash += *s * coeff[i];
  702. X    }
  703. X    }
  704. X
  705. X    entry = tb->tbl_array[hash & tb->tbl_max];
  706. X    for (; entry; entry = entry->hent_next) {
  707. X    if (entry->hent_hash != hash)        /* strings can't be equal */
  708. X        continue;
  709. X    if (entry->hent_klen != klen)
  710. X        continue;
  711. X    if (bcmp(entry->hent_key,key,klen))    /* is this it? */
  712. X        continue;
  713. X    return entry->hent_val;
  714. X    }
  715. X#ifdef SOME_DBM
  716. X    if (tb->tbl_dbm) {
  717. X    dkey.dptr = key;
  718. X    dkey.dsize = klen;
  719. X    dcontent = dbm_fetch(tb->tbl_dbm,dkey);
  720. X    if (dcontent.dptr) {            /* found one */
  721. X        str = Str_new(60,dcontent.dsize);
  722. X        str_nset(str,dcontent.dptr,dcontent.dsize);
  723. X        hstore(tb,key,klen,str,hash);        /* cache it */
  724. X        return str;
  725. X    }
  726. X    }
  727. X#endif
  728. X    if (lval) {        /* gonna assign to this, so it better be there */
  729. X    str = Str_new(61,0);
  730. X    hstore(tb,key,klen,str,hash);
  731. X    return str;
  732. X    }
  733. X    return Nullstr;
  734. X}
  735. X
  736. Xbool
  737. Xhstore(tb,key,klen,val,hash)
  738. Xregister HASH *tb;
  739. Xchar *key;
  740. Xint klen;
  741. XSTR *val;
  742. Xregister int hash;
  743. X{
  744. X    register char *s;
  745. X    register int i;
  746. X    register HENT *entry;
  747. X    register HENT **oentry;
  748. X    register int maxi;
  749. X
  750. X    if (!tb)
  751. X    return FALSE;
  752. X
  753. X    if (hash)
  754. X    ;
  755. X    else if (!tb->tbl_coeffsize)
  756. X    hash = *key + 128 * key[1] + 128 * key[klen-1];
  757. X    else {    /* use normal coefficients */
  758. X    if (klen < tb->tbl_coeffsize)
  759. X        maxi = klen;
  760. X    else
  761. X        maxi = tb->tbl_coeffsize;
  762. X    for (s=key,        i=0,    hash = 0;
  763. X                i < maxi;
  764. X         s++,        i++,    hash *= 5) {
  765. X        hash += *s * coeff[i];
  766. X    }
  767. X    }
  768. X
  769. X    oentry = &(tb->tbl_array[hash & tb->tbl_max]);
  770. X    i = 1;
  771. X
  772. X    for (entry = *oentry; entry; i=0, entry = entry->hent_next) {
  773. X    if (entry->hent_hash != hash)        /* strings can't be equal */
  774. X        continue;
  775. X    if (entry->hent_klen != klen)
  776. X        continue;
  777. X    if (bcmp(entry->hent_key,key,klen))    /* is this it? */
  778. X        continue;
  779. X    Safefree(entry->hent_val);
  780. X    entry->hent_val = val;
  781. X    return TRUE;
  782. X    }
  783. X    New(501,entry, 1, HENT);
  784. X
  785. X    entry->hent_klen = klen;
  786. X    entry->hent_key = nsavestr(key,klen);
  787. X    entry->hent_val = val;
  788. X    entry->hent_hash = hash;
  789. X    entry->hent_next = *oentry;
  790. X    *oentry = entry;
  791. X
  792. X    /* hdbmstore not necessary here because it's called from stabset() */
  793. X
  794. X    if (i) {                /* initial entry? */
  795. X    tb->tbl_fill++;
  796. X#ifdef SOME_DBM
  797. X    if (tb->tbl_dbm && tb->tbl_max >= DBM_CACHE_MAX)
  798. X        return FALSE;
  799. X#endif
  800. X    if (tb->tbl_fill > tb->tbl_dosplit)
  801. X        hsplit(tb);
  802. X    }
  803. X#ifdef SOME_DBM
  804. X    else if (tb->tbl_dbm) {        /* is this just a cache for dbm file? */
  805. X    entry = tb->tbl_array[hash & tb->tbl_max];
  806. X    oentry = &entry->hent_next;
  807. X    entry = *oentry;
  808. X    while (entry) {    /* trim chain down to 1 entry */
  809. X        *oentry = entry->hent_next;
  810. X        hentfree(entry);        /* no doubt they'll want this next. */
  811. X        entry = *oentry;
  812. X    }
  813. X    }
  814. X#endif
  815. X
  816. X    return FALSE;
  817. X}
  818. X
  819. XSTR *
  820. Xhdelete(tb,key,klen)
  821. Xregister HASH *tb;
  822. Xchar *key;
  823. Xint klen;
  824. X{
  825. X    register char *s;
  826. X    register int i;
  827. X    register int hash;
  828. X    register HENT *entry;
  829. X    register HENT **oentry;
  830. X    STR *str;
  831. X    int maxi;
  832. X#ifdef SOME_DBM
  833. X    datum dkey;
  834. X#endif
  835. X
  836. X    if (!tb)
  837. X    return Nullstr;
  838. X    if (!tb->tbl_coeffsize)
  839. X    hash = *key + 128 * key[1] + 128 * key[klen-1];
  840. X    else {    /* use normal coefficients */
  841. X    if (klen < tb->tbl_coeffsize)
  842. X        maxi = klen;
  843. X    else
  844. X        maxi = tb->tbl_coeffsize;
  845. X    for (s=key,        i=0,    hash = 0;
  846. X                i < maxi;
  847. X         s++,        i++,    hash *= 5) {
  848. X        hash += *s * coeff[i];
  849. X    }
  850. X    }
  851. X
  852. X    oentry = &(tb->tbl_array[hash & tb->tbl_max]);
  853. X    entry = *oentry;
  854. X    i = 1;
  855. X    for (; entry; i=0, oentry = &entry->hent_next, entry = *oentry) {
  856. X    if (entry->hent_hash != hash)        /* strings can't be equal */
  857. X        continue;
  858. X    if (entry->hent_klen != klen)
  859. X        continue;
  860. X    if (bcmp(entry->hent_key,key,klen))    /* is this it? */
  861. X        continue;
  862. X    *oentry = entry->hent_next;
  863. X    str = str_static(entry->hent_val);
  864. X    hentfree(entry);
  865. X    if (i)
  866. X        tb->tbl_fill--;
  867. X#ifdef SOME_DBM
  868. X      do_dbm_delete:
  869. X    if (tb->tbl_dbm) {
  870. X        dkey.dptr = key;
  871. X        dkey.dsize = klen;
  872. X        dbm_delete(tb->tbl_dbm,dkey);
  873. X    }
  874. X#endif
  875. X    return str;
  876. X    }
  877. X#ifdef SOME_DBM
  878. X    str = Nullstr;
  879. X    goto do_dbm_delete;
  880. X#else
  881. X    return Nullstr;
  882. X#endif
  883. X}
  884. X
  885. Xhsplit(tb)
  886. XHASH *tb;
  887. X{
  888. X    int oldsize = tb->tbl_max + 1;
  889. X    register int newsize = oldsize * 2;
  890. X    register int i;
  891. X    register HENT **a;
  892. X    register HENT **b;
  893. X    register HENT *entry;
  894. X    register HENT **oentry;
  895. X
  896. X    a = tb->tbl_array;
  897. X    Renew(a, newsize, HENT*);
  898. X    Zero(&a[oldsize], oldsize, HENT*);        /* zero 2nd half*/
  899. X    tb->tbl_max = --newsize;
  900. X    tb->tbl_dosplit = tb->tbl_max * FILLPCT / 100;
  901. X    tb->tbl_array = a;
  902. X
  903. X    for (i=0; i<oldsize; i++,a++) {
  904. X    if (!*a)                /* non-existent */
  905. X        continue;
  906. X    b = a+oldsize;
  907. X    for (oentry = a, entry = *a; entry; entry = *oentry) {
  908. X        if ((entry->hent_hash & newsize) != i) {
  909. X        *oentry = entry->hent_next;
  910. X        entry->hent_next = *b;
  911. X        if (!*b)
  912. X            tb->tbl_fill++;
  913. X        *b = entry;
  914. X        continue;
  915. X        }
  916. X        else
  917. X        oentry = &entry->hent_next;
  918. X    }
  919. X    if (!*a)                /* everything moved */
  920. X        tb->tbl_fill--;
  921. X    }
  922. X}
  923. X
  924. XHASH *
  925. Xhnew(lookat)
  926. Xunsigned int lookat;
  927. X{
  928. X    register HASH *tb;
  929. X
  930. X    Newz(502,tb, 1, HASH);
  931. X    if (lookat) {
  932. X    tb->tbl_coeffsize = lookat;
  933. X    tb->tbl_max = 7;        /* it's a normal associative array */
  934. X    tb->tbl_dosplit = tb->tbl_max * FILLPCT / 100;
  935. X    }
  936. X    else {
  937. X    tb->tbl_max = 127;        /* it's a symbol table */
  938. X    tb->tbl_dosplit = 128;        /* so never split */
  939. X    }
  940. X    Newz(503,tb->tbl_array, tb->tbl_max + 1, HENT*);
  941. X    tb->tbl_fill = 0;
  942. X#ifdef SOME_DBM
  943. X    tb->tbl_dbm = 0;
  944. X#endif
  945. X    (void)hiterinit(tb);    /* so each() will start off right */
  946. X    return tb;
  947. X}
  948. X
  949. Xvoid
  950. Xhentfree(hent)
  951. Xregister HENT *hent;
  952. X{
  953. X    if (!hent)
  954. X    return;
  955. X    str_free(hent->hent_val);
  956. X    Safefree(hent->hent_key);
  957. X    Safefree(hent);
  958. X}
  959. X
  960. Xvoid
  961. Xhclear(tb)
  962. Xregister HASH *tb;
  963. X{
  964. X    register HENT *hent;
  965. X    register HENT *ohent = Null(HENT*);
  966. X
  967. X    if (!tb)
  968. X    return;
  969. X    (void)hiterinit(tb);
  970. X    while (hent = hiternext(tb)) {    /* concise but not very efficient */
  971. X    hentfree(ohent);
  972. X    ohent = hent;
  973. X    }
  974. X    hentfree(ohent);
  975. X    tb->tbl_fill = 0;
  976. X#ifndef lint
  977. X    (void)bzero((char*)tb->tbl_array, (tb->tbl_max + 1) * sizeof(HENT*));
  978. X#endif
  979. X}
  980. X
  981. Xvoid
  982. Xhfree(tb)
  983. Xregister HASH *tb;
  984. X{
  985. X    register HENT *hent;
  986. X    register HENT *ohent = Null(HENT*);
  987. X
  988. X    if (!tb)
  989. X    return;
  990. X    (void)hiterinit(tb);
  991. X    while (hent = hiternext(tb)) {
  992. X    hentfree(ohent);
  993. X    ohent = hent;
  994. X    }
  995. X    hentfree(ohent);
  996. X    Safefree(tb->tbl_array);
  997. X    Safefree(tb);
  998. X}
  999. X
  1000. Xint
  1001. Xhiterinit(tb)
  1002. Xregister HASH *tb;
  1003. X{
  1004. X    tb->tbl_riter = -1;
  1005. X    tb->tbl_eiter = Null(HENT*);
  1006. X    return tb->tbl_fill;
  1007. X}
  1008. X
  1009. XHENT *
  1010. Xhiternext(tb)
  1011. Xregister HASH *tb;
  1012. X{
  1013. X    register HENT *entry;
  1014. X#ifdef SOME_DBM
  1015. X    datum key;
  1016. X#endif
  1017. X
  1018. X    entry = tb->tbl_eiter;
  1019. X#ifdef SOME_DBM
  1020. X    if (tb->tbl_dbm) {
  1021. X    if (entry) {
  1022. X#ifdef NDBM
  1023. X#ifdef _CX_UX
  1024. X        key = dbm_nextkey(tb->tbl_dbm, key);
  1025. X#else
  1026. X        key = dbm_nextkey(tb->tbl_dbm);
  1027. X#endif /* _CX_UX */
  1028. X#else
  1029. X        key.dptr = entry->hent_key;
  1030. X        key.dsize = entry->hent_klen;
  1031. X        key = nextkey(key);
  1032. X#endif
  1033. X    }
  1034. X    else {
  1035. X        Newz(504,entry, 1, HENT);
  1036. X        tb->tbl_eiter = entry;
  1037. X        key = dbm_firstkey(tb->tbl_dbm);
  1038. X    }
  1039. X    entry->hent_key = key.dptr;
  1040. X    entry->hent_klen = key.dsize;
  1041. X    if (!key.dptr) {
  1042. X        if (entry->hent_val)
  1043. X        str_free(entry->hent_val);
  1044. X        Safefree(entry);
  1045. X        tb->tbl_eiter = Null(HENT*);
  1046. X        return Null(HENT*);
  1047. X    }
  1048. X    return entry;
  1049. X    }
  1050. X#endif
  1051. X    do {
  1052. X    if (entry)
  1053. X        entry = entry->hent_next;
  1054. X    if (!entry) {
  1055. X        tb->tbl_riter++;
  1056. X        if (tb->tbl_riter > tb->tbl_max) {
  1057. X        tb->tbl_riter = -1;
  1058. X        break;
  1059. X        }
  1060. X        entry = tb->tbl_array[tb->tbl_riter];
  1061. X    }
  1062. X    } while (!entry);
  1063. X
  1064. X    tb->tbl_eiter = entry;
  1065. X    return entry;
  1066. X}
  1067. X
  1068. Xchar *
  1069. Xhiterkey(entry,retlen)
  1070. Xregister HENT *entry;
  1071. Xint *retlen;
  1072. X{
  1073. X    *retlen = entry->hent_klen;
  1074. X    return entry->hent_key;
  1075. X}
  1076. X
  1077. XSTR *
  1078. Xhiterval(tb,entry)
  1079. Xregister HASH *tb;
  1080. Xregister HENT *entry;
  1081. X{
  1082. X#ifdef SOME_DBM
  1083. X    datum key, content;
  1084. X
  1085. X    if (tb->tbl_dbm) {
  1086. X    key.dptr = entry->hent_key;
  1087. X    key.dsize = entry->hent_klen;
  1088. X    content = dbm_fetch(tb->tbl_dbm,key);
  1089. X    if (!entry->hent_val)
  1090. X        entry->hent_val = Str_new(62,0);
  1091. X    str_nset(entry->hent_val,content.dptr,content.dsize);
  1092. X    }
  1093. X#endif
  1094. X    return entry->hent_val;
  1095. X}
  1096. X
  1097. X#ifdef SOME_DBM
  1098. X#if    defined(FCNTL) && ! defined(O_CREAT)
  1099. X#include <fcntl.h>
  1100. X#endif
  1101. X
  1102. X#ifndef O_RDONLY
  1103. X#define O_RDONLY 0
  1104. X#endif
  1105. X#ifndef O_RDWR
  1106. X#define O_RDWR 2
  1107. X#endif
  1108. X#ifndef O_CREAT
  1109. X#define O_CREAT 01000
  1110. X#endif
  1111. X
  1112. X#ifndef NDBM
  1113. Xstatic int dbmrefcnt = 0;
  1114. X#endif
  1115. X
  1116. Xbool
  1117. Xhdbmopen(tb,fname,mode)
  1118. Xregister HASH *tb;
  1119. Xchar *fname;
  1120. Xint mode;
  1121. X{
  1122. X    if (!tb)
  1123. X    return FALSE;
  1124. X#ifndef NDBM
  1125. X    if (tb->tbl_dbm)    /* never really closed it */
  1126. X    return TRUE;
  1127. X#endif
  1128. X    if (tb->tbl_dbm)
  1129. X    hdbmclose(tb);
  1130. X    hclear(tb);
  1131. X#ifdef NDBM
  1132. X    tb->tbl_dbm = dbm_open(fname, O_RDWR|O_CREAT, mode);
  1133. X    if (!tb->tbl_dbm)        /* oops, just try reading it */
  1134. X    tb->tbl_dbm = dbm_open(fname, O_RDONLY, mode);
  1135. X#else
  1136. X    if (dbmrefcnt++)
  1137. X    fatal("Old dbm can only open one database");
  1138. X    sprintf(buf,"%s.dir",fname);
  1139. X    if (stat(buf, &statbuf) < 0) {
  1140. X    if (close(creat(buf,mode)) < 0)
  1141. X        return FALSE;
  1142. X    sprintf(buf,"%s.pag",fname);
  1143. X    if (close(creat(buf,mode)) < 0)
  1144. X        return FALSE;
  1145. X    }
  1146. X    tb->tbl_dbm = dbminit(fname) >= 0;
  1147. X#endif
  1148. X    return tb->tbl_dbm != 0;
  1149. X}
  1150. X
  1151. Xvoid
  1152. Xhdbmclose(tb)
  1153. Xregister HASH *tb;
  1154. X{
  1155. X    if (tb && tb->tbl_dbm) {
  1156. X#ifdef NDBM
  1157. X    dbm_close(tb->tbl_dbm);
  1158. X    tb->tbl_dbm = 0;
  1159. X#else
  1160. X    /* dbmrefcnt--;  */    /* doesn't work, rats */
  1161. X#endif
  1162. X    }
  1163. X    else if (dowarn)
  1164. X    warn("Close on unopened dbm file");
  1165. X}
  1166. X
  1167. Xbool
  1168. Xhdbmstore(tb,key,klen,str)
  1169. Xregister HASH *tb;
  1170. Xchar *key;
  1171. Xint klen;
  1172. Xregister STR *str;
  1173. X{
  1174. X    datum dkey, dcontent;
  1175. X    int error;
  1176. X
  1177. X    if (!tb || !tb->tbl_dbm)
  1178. X    return FALSE;
  1179. X    dkey.dptr = key;
  1180. X    dkey.dsize = klen;
  1181. X    dcontent.dptr = str_get(str);
  1182. X    dcontent.dsize = str->str_cur;
  1183. X    error = dbm_store(tb->tbl_dbm, dkey, dcontent, DBM_REPLACE);
  1184. X    if (error) {
  1185. X    if (errno == EPERM)
  1186. X        fatal("No write permission to dbm file");
  1187. X    warn("dbm store returned %d, errno %d, key \"%s\"",error,errno,key);
  1188. X#ifdef NDBM
  1189. X        dbm_clearerr(tb->tbl_dbm);
  1190. X#endif
  1191. X    }
  1192. X    return !error;
  1193. X}
  1194. X#endif /* SOME_DBM */
  1195. !STUFFY!FUNK!
  1196. echo Extracting lib/perldb.pl
  1197. sed >lib/perldb.pl <<'!STUFFY!FUNK!' -e 's/X//'
  1198. Xpackage DB;
  1199. X
  1200. X$header = '$Header: perldb.pl,v 3.0 89/10/18 15:19:46 lwall Locked $';
  1201. X#
  1202. X# This file is automatically included if you do perl -d.
  1203. X# It's probably not useful to include this yourself.
  1204. X#
  1205. X# Perl supplies the values for @line and %sub.  It effectively inserts
  1206. X# a do DB'DB(<linenum>); in front of every place that can
  1207. X# have a breakpoint.  It also inserts a do 'perldb.pl' before the first line.
  1208. X#
  1209. X# $Log:    perldb.pl,v $
  1210. X# Revision 3.0  89/10/18  15:19:46  lwall
  1211. X# 3.0 baseline
  1212. X# 
  1213. X# Revision 2.0  88/06/05  00:09:45  root
  1214. X# Baseline version 2.0.
  1215. X# 
  1216. X#
  1217. X
  1218. Xopen(IN,"/dev/tty");        # so we don't dingle stdin
  1219. Xopen(OUT,">/dev/tty");    # so we don't dongle stdout
  1220. Xselect(OUT);
  1221. X$| = 1;                # for DB'OUT
  1222. Xselect(STDOUT);
  1223. X$| = 1;                # for real STDOUT
  1224. X
  1225. X$header =~ s/\$Header: perldb.pl,v 3.0 89/10/18 15:19:46 lwall Locked $/$1$2/;
  1226. Xprint OUT "\nLoading DB from $header\n\n";
  1227. X
  1228. Xsub DB {
  1229. X    local($. ,$@, $!, $[, $,, $/, $\);
  1230. X    $[ = 0; $, = ""; $/ = "\n"; $\ = "";
  1231. X    ($line) = @_;
  1232. X    if ($stop[$line]) {
  1233. X    if ($stop eq '1') {
  1234. X        $signal |= 1;
  1235. X    }
  1236. X    else {
  1237. X        package main;
  1238. X        $DB'signal |= eval $DB'stop[$DB'line];  print DB'OUT $@;
  1239. X        $DB'stop[$DB'line] =~ s/;9$//;
  1240. X    }
  1241. X    }
  1242. X    if ($single || $trace || $signal) {
  1243. X    print OUT "$sub($line):\t",$line[$line];
  1244. X    for ($i = $line + 1; $i <= $max && $line[$i] == 0; ++$i) {
  1245. X        last if $line[$i] =~ /^\s*(}|#|\n)/;
  1246. X        print OUT "$sub($i):\t",$line[$i];
  1247. X    }
  1248. X    }
  1249. X    if ($action[$line]) {
  1250. X    package main;
  1251. X    eval $DB'action[$DB'line];  print DB'OUT $@;
  1252. X    }
  1253. X    if ($single || $signal) {
  1254. X    if ($pre) {
  1255. X        package main;
  1256. X        eval $DB'pre;  print DB'OUT $@;
  1257. X    }
  1258. X    print OUT $#stack . " levels deep in subroutine calls!\n"
  1259. X        if $single & 4;
  1260. X    $start = $line;
  1261. X    while ((print OUT "  DB<", $#hist+1, "> "), $cmd=<IN>) {
  1262. X        $single = 0;
  1263. X        $signal = 0;
  1264. X        $cmd eq '' && exit 0;
  1265. X        chop($cmd);
  1266. X        $cmd =~ /^q$/ && exit 0;
  1267. X        $cmd =~ /^$/ && ($cmd = $laststep);
  1268. X        push(@hist,$cmd) if length($cmd) > 1;
  1269. X        ($i) = split(/\s+/,$cmd);
  1270. X        eval "\$cmd =~ $alias{$i}", print OUT $@ if $alias{$i};
  1271. X        $cmd =~ /^h$/ && do {
  1272. X        print OUT "
  1273. XT        Stack trace.
  1274. Xs        Single step.
  1275. Xn        Next, steps over subroutine calls.
  1276. Xf        Finish current subroutine.
  1277. Xc [line]    Continue; optionally inserts a one-time-only breakpoint 
  1278. X        at the specified line.
  1279. X<CR>        Repeat last n or s.
  1280. Xl min+incr    List incr+1 lines starting at min.
  1281. Xl min-max    List lines.
  1282. Xl line        List line;
  1283. Xl        List next window.
  1284. X-        List previous window.
  1285. Xw line        List window around line.
  1286. Xl subname    List subroutine.
  1287. X/pattern/    Search forwards for pattern; final / is optional.
  1288. X?pattern?    Search backwards for pattern.
  1289. XL        List breakpoints and actions.
  1290. XS        List subroutine names.
  1291. Xt        Toggle trace mode.
  1292. Xb [line] [condition]
  1293. X        Set breakpoint; line defaults to the current execution line; 
  1294. X        condition breaks if it evaluates to true, defaults to \'1\'.
  1295. Xb subname [condition]
  1296. X        Set breakpoint at first line of subroutine.
  1297. Xd [line]    Delete breakpoint.
  1298. XD        Delete all breakpoints.
  1299. Xa [line] command
  1300. X        Set an action to be done before the line is executed.
  1301. X        Sequence is: check for breakpoint, print line if necessary,
  1302. X        do action, prompt user if breakpoint or step, evaluate line.
  1303. XA        Delete all actions.
  1304. XV package    List all variables and values in package (default main).
  1305. X< command    Define command before prompt.
  1306. X> command    Define command after prompt.
  1307. X! number    Redo command (default previous command).
  1308. X! -number    Redo number\'th to last command.
  1309. XH -number    Display last number commands (default all).
  1310. Xq or ^D        Quit.
  1311. Xp expr        Same as \"package main; print DB'OUT expr\".
  1312. Xcommand        Execute as a perl statement.
  1313. X
  1314. X";
  1315. X        next; };
  1316. X        $cmd =~ /^t$/ && do {
  1317. X        $trace = !$trace;
  1318. X        print OUT "Trace = ".($trace?"on":"off")."\n";
  1319. X        next; };
  1320. X        $cmd =~ /^S$/ && do {
  1321. X        foreach $subname (sort(keys %sub)) {
  1322. X            if ($subname =~ /^main'(.*)/) {
  1323. X            print OUT $1,"\n";
  1324. X            }
  1325. X            else {
  1326. X            print OUT $subname,"\n";
  1327. X            }
  1328. X        }
  1329. X        next; };
  1330. X        $cmd =~ /^V$/ && do {
  1331. X        $cmd = 'V main'; };
  1332. X        $cmd =~ /^V\s*(['A-Za-z_]['\w]*)$/ && do {
  1333. X        $packname = $1;
  1334. X        do 'dumpvar.pl' unless defined &main'dumpvar;
  1335. X        if (defined &main'dumpvar) {
  1336. X            &main'dumpvar($packname);
  1337. X        }
  1338. X        else {
  1339. X            print DB'OUT "dumpvar.pl not available.\n";
  1340. X        }
  1341. X        next; };
  1342. X        $cmd =~ /^l\s*(['A-Za-z_]['\w]*)/ && do {
  1343. X        $subname = $1;
  1344. X        $subname = "main'" . $subname unless $subname =~ /'/;
  1345. X        $subrange = $sub{$subname};
  1346. X        if ($subrange) {
  1347. X            if (eval($subrange) < -$window) {
  1348. X            $subrange =~ s/-.*/+/;
  1349. X            }
  1350. X            $cmd = "l $subrange";
  1351. X        } else {
  1352. X            print OUT "Subroutine $1 not found.\n";
  1353. X            next;
  1354. X        } };
  1355. X        $cmd =~ /^w\s*(\d*)$/ && do {
  1356. X        $incr = $window - 1;
  1357. X        $start = $1 if $1;
  1358. X        $start -= $preview;
  1359. X        $cmd = 'l ' . $start . '-' . ($start + $incr); };
  1360. X        $cmd =~ /^-$/ && do {
  1361. X        $incr = $window - 1;
  1362. X        $cmd = 'l ' . ($start-$window*2) . '+'; };
  1363. X        $cmd =~ /^l$/ && do {
  1364. X        $incr = $window - 1;
  1365. X        $cmd = 'l ' . $start . '-' . ($start + $incr); };
  1366. X        $cmd =~ /^l\s*(\d*)\+(\d*)$/ && do {
  1367. X        $start = $1 if $1;
  1368. X        $incr = $2;
  1369. X        $incr = $window - 1 unless $incr;
  1370. X        $cmd = 'l ' . $start . '-' . ($start + $incr); };
  1371. X        $cmd =~ /^l\s*(([\d\$\.]+)([-,]([\d\$\.]+))?)?/ && do {
  1372. X        $end = (!$2) ? $max : ($4 ? $4 : $2);
  1373. X        $end = $max if $end > $max;
  1374. X        $i = $2;
  1375. X        $i = $line if $i eq '.';
  1376. X        $i = 1 if $i < 1;
  1377. X        for (; $i <= $end; $i++) {
  1378. X            print OUT "$i:\t", $line[$i];
  1379. X            last if $signal;
  1380. X        }
  1381. X        $start = $i;    # remember in case they want more
  1382. X        $start = $max if $start > $max;
  1383. X        next; };
  1384. X        $cmd =~ /^D$/ && do {
  1385. X        print OUT "Deleting all breakpoints...\n";
  1386. X        for ($i = 1; $i <= $max ; $i++) {
  1387. X            $stop[$i] = 0;
  1388. X        }
  1389. X        next; };
  1390. X        $cmd =~ /^L$/ && do {
  1391. X        for ($i = 1; $i <= $max; $i++) {
  1392. X            if ($stop[$i] || $action[$i]) {
  1393. X            print OUT "$i:\t", $line[$i];
  1394. X            print OUT "  break if (", $stop[$i], ")\n" 
  1395. X                if $stop[$i];
  1396. X            print OUT "  action:  ", $action[$i], "\n" 
  1397. X                if $action[$i];
  1398. X            last if $signal;
  1399. X            }
  1400. X        }
  1401. X        next; };
  1402. X        $cmd =~ /^b\s*(['A-Za-z_]['\w]*)\s*(.*)/ && do {
  1403. X        $subname = $1;
  1404. X        $subname = "main'" . $subname unless $subname =~ /'/;
  1405. X        ($i) = split(/-/, $sub{$subname});
  1406. X        if ($i) {
  1407. X            ++$i while $line[$i] == 0 && $i < $#line;
  1408. X            $stop[$i] = $2 ? $2 : 1;
  1409. X        } else {
  1410. X            print OUT "Subroutine $1 not found.\n";
  1411. X        }
  1412. X        next; };
  1413. X        $cmd =~ /^b\s*(\d*)\s*(.*)/ && do {
  1414. X        $i = ($1?$1:$line);
  1415. X        if ($line[$i] == 0) {
  1416. X            print OUT "Line $i not breakable.\n";
  1417. X        } else {
  1418. X            $stop[$i] = $2 ? $2 : 1;
  1419. X        }
  1420. X        next; };
  1421. X        $cmd =~ /^d\s*(\d+)?/ && do {
  1422. X        $i = ($1?$1:$line);
  1423. X        $stop[$i] = '';
  1424. X        next; };
  1425. X        $cmd =~ /^A$/ && do {
  1426. X        for ($i = 1; $i <= $max ; $i++) {
  1427. X            $action[$i] = '';
  1428. X        }
  1429. X        next; };
  1430. X        $cmd =~ /^<\s*(.*)/ && do {
  1431. X        $pre = do action($1);
  1432. X        next; };
  1433. X        $cmd =~ /^>\s*(.*)/ && do {
  1434. X        $post = do action($1);
  1435. X        next; };
  1436. X        $cmd =~ /^a\s*(\d+)(\s+(.*))?/ && do {
  1437. X        $i = $1;
  1438. X        if ($line[$i] == 0) {
  1439. X            print OUT "Line $i may not have an action.\n";
  1440. X        } else {
  1441. X            $action[$i] = do action($3);
  1442. X        }
  1443. X        next; };
  1444. X        $cmd =~ /^n$/ && do {
  1445. X        $single = 2;
  1446. X        $laststep = $cmd;
  1447. X        last; };
  1448. X        $cmd =~ /^s$/ && do {
  1449. X        $single = 1;
  1450. X        $laststep = $cmd;
  1451. X        last; };
  1452. X        $cmd =~ /^c\s*(\d*)\s*$/ && do {
  1453. X        $i = $1;
  1454. X        if ($i) {
  1455. X            if ($line[$i] == 0) {
  1456. X                print OUT "Line $i not breakable.\n";
  1457. X            next;
  1458. X            }
  1459. X            $stop[$i] .= ";9";    # add one-time-only b.p.
  1460. X        }
  1461. X        for ($i=0; $i <= $#stack; ) {
  1462. X            $stack[$i++] &= ~1;
  1463. X        }
  1464. X        last; };
  1465. X        $cmd =~ /^f$/ && do {
  1466. X        $stack[$#stack] |= 2;
  1467. X        last; };
  1468. X        $cmd =~ /^T$/ && do {
  1469. X        for ($i=0; $i <= $#sub; ) {
  1470. X            print OUT $sub[$i++], "\n";
  1471. X            last if $signal;
  1472. X        }
  1473. X            next; };
  1474. X        $cmd =~ /^\/(.*)$/ && do {
  1475. X        $inpat = $1;
  1476. X        $inpat =~ s:([^\\])/$:$1:;
  1477. X        if ($inpat ne "") {
  1478. X            eval '$inpat =~ m'."\n$inpat\n";    
  1479. X            if ($@ ne "") {
  1480. X                print OUT "$@";
  1481. X                next;
  1482. X            }
  1483. X            $pat = $inpat;
  1484. X        }
  1485. X        $end = $start;
  1486. X        eval '
  1487. X        for (;;) {
  1488. X            ++$start;
  1489. X            $start = 1 if ($start > $max);
  1490. X            last if ($start == $end);
  1491. X            if ($line[$start] =~ m'."\n$pat\n".'i) {
  1492. X            print OUT "$start:\t", $line[$start], "\n";
  1493. X            last;
  1494. X            }
  1495. X        } ';
  1496. X        print OUT "/$pat/: not found\n" if ($start == $end);
  1497. X        next; };
  1498. X        $cmd =~ /^\?(.*)$/ && do {
  1499. X        $inpat = $1;
  1500. X        $inpat =~ s:([^\\])\?$:$1:;
  1501. X        if ($inpat ne "") {
  1502. X            eval '$inpat =~ m'."\n$inpat\n";    
  1503. X            if ($@ ne "") {
  1504. X                print OUT "$@";
  1505. X                next;
  1506. X            }
  1507. X            $pat = $inpat;
  1508. X        }
  1509. X        $end = $start;
  1510. X        eval '
  1511. X        for (;;) {
  1512. X            --$start;
  1513. X            $start = $max if ($start <= 0);
  1514. X            last if ($start == $end);
  1515. X            if ($line[$start] =~ m'."\n$pat\n".'i) {
  1516. X            print OUT "$start:\t", $line[$start], "\n";
  1517. X            last;
  1518. X            }
  1519. X        } ';
  1520. X        print OUT "?$pat?: not found\n" if ($start == $end);
  1521. X        next; };
  1522. X        $cmd =~ /^!+\s*(-)?(\d+)?$/ && do {
  1523. X        pop(@hist) if length($cmd) > 1;
  1524. X        $i = ($1?($#hist-($2?$2:1)):($2?$2:$#hist));
  1525. X        $cmd = $hist[$i] . "\n";
  1526. X        print OUT $cmd;
  1527. X        redo; };
  1528. X        $cmd =~ /^!(.+)$/ && do {
  1529. X        $pat = "^$1";
  1530. X        pop(@hist) if length($cmd) > 1;
  1531. X        for ($i = $#hist; $i; --$i) {
  1532. X            last if $hist[$i] =~ $pat;
  1533. X        }
  1534. X        if (!$i) {
  1535. X            print OUT "No such command!\n\n";
  1536. X            next;
  1537. X        }
  1538. X        $cmd = $hist[$i] . "\n";
  1539. X        print OUT $cmd;
  1540. X        redo; };
  1541. X        $cmd =~ /^H\s*(-(\d+))?/ && do {
  1542. X        $end = $2?($#hist-$2):0;
  1543. X        $hist = 0 if $hist < 0;
  1544. X        for ($i=$#hist; $i>$end; $i--) {
  1545. X            print OUT "$i: ",$hist[$i],"\n"
  1546. X            unless $hist[$i] =~ /^.?$/;
  1547. X        };
  1548. X        next; };
  1549. X        $cmd =~ s/^p( .*)?$/print DB'OUT$1/;
  1550. X        {
  1551. X        package main;
  1552. X        eval $DB'cmd;
  1553. X        }
  1554. X        print OUT $@,"\n";
  1555. X    }
  1556. X    if ($post) {
  1557. X        package main;
  1558. X        eval $DB'post;  print DB'OUT $@;
  1559. X    }
  1560. X    }
  1561. X}
  1562. X
  1563. Xsub action {
  1564. X    local($action) = @_;
  1565. X    while ($action =~ s/\\$//) {
  1566. X    print OUT "+ ";
  1567. X    $action .= <IN>;
  1568. X    }
  1569. X    $action;
  1570. X}
  1571. X
  1572. Xsub catch {
  1573. X    $signal = 1;
  1574. X}
  1575. X
  1576. Xsub sub {
  1577. X    push(@stack, $single);
  1578. X    $single &= 1;
  1579. X    $single |= 4 if $#stack == $deep;
  1580. X    local(@args) = @_;
  1581. X    for (@args) {
  1582. X    if (/^Stab/ && length($_) == length($_main{'_main'})) {
  1583. X        $_ = sprintf("%s",$_);
  1584. X        print "ARG: $_\n";
  1585. X    }
  1586. X    else {
  1587. X        s/'/\\'/g;
  1588. X        s/(.*)/'$1'/ unless /^-?[\d.]+$/;
  1589. X    }
  1590. X    }
  1591. X    push(@sub, $sub . '(' . join(', ', @args) . ') from ' . $line);
  1592. X    if (wantarray) {
  1593. X    @i = &$sub;
  1594. X    }
  1595. X    else {
  1596. X    $i = &$sub;
  1597. X    @i = $i;
  1598. X    }
  1599. X    --$#sub;
  1600. X    $single |= pop(@stack);
  1601. X    @i;
  1602. X}
  1603. X
  1604. X$single = 1;            # so it stops on first executable statement
  1605. X$max = $#line;
  1606. X@hist = ('?');
  1607. X$SIG{'INT'} = "DB'catch";
  1608. X$deep = 100;        # warning if stack gets this deep
  1609. X$window = 10;
  1610. X$preview = 3;
  1611. X
  1612. X@stack = (0);
  1613. X@args = @ARGV;
  1614. Xfor (@args) {
  1615. X    s/'/\\'/g;
  1616. X    s/(.*)/'$1'/ unless /^-?[\d.]+$/;
  1617. X}
  1618. Xpush(@sub, 'main(' . join(', ', @args) . ")" );
  1619. X$sub = 'main';
  1620. X
  1621. Xif (-f '.perldb') {
  1622. X    do './.perldb';
  1623. X}
  1624. Xelsif (-f "$ENV{'LOGDIR'}/.perldb") {
  1625. X    do "$ENV{'LOGDIR'}/.perldb";
  1626. X}
  1627. Xelsif (-f "$ENV{'HOME'}/.perldb") {
  1628. X    do "$ENV{'HOME'}/.perldb";
  1629. X}
  1630. X
  1631. X1;
  1632. !STUFFY!FUNK!
  1633. echo Extracting PACKINGLIST
  1634. sed >PACKINGLIST <<'!STUFFY!FUNK!' -e 's/X//'
  1635. XAfter all the perl kits are run you should have the following files:
  1636. X
  1637. XFilename        Kit Description
  1638. X--------        --- -----------
  1639. XChanges                 20 Differences between 2.0 level 18 and 3.0 level 0
  1640. XConfigure                2 Run this first
  1641. XCopying                 10 The GNU General Public License
  1642. XEXTERN.h                24 Included before foreign .h files
  1643. XINTERN.h                24 Included before domestic .h files
  1644. XMANIFEST                20 This list of files
  1645. XMakefile.SH             19 Precursor to Makefile
  1646. XPACKINGLIST             18 Which files came from which kits
  1647. XREADME                   1 The Instructions
  1648. XWishlist                24 Some things that may or may not happen
  1649. Xarg.h                   11 Public declarations for the above
  1650. Xarray.c                 21 Numerically subscripted arrays
  1651. Xarray.h                 24 Public declarations for the above
  1652. Xclient                  24 A client to test sockets
  1653. Xcmd.c                   15 Command interpreter
  1654. Xcmd.h                   21 Public declarations for the above
  1655. Xconfig.H                15 Sample config.h
  1656. Xconfig.h.SH             14 Produces config.h
  1657. Xcons.c                  10 Routines to construct cmd nodes of a parse tree
  1658. Xconsarg.c               14 Routines to construct arg nodes of a parse tree
  1659. Xdoarg.c                 11 Scalar expression evaluation
  1660. Xdoio.c                   7 I/O operations
  1661. Xdolist.c                16 Array expression evaluation
  1662. Xdump.c                  20 Debugging output
  1663. Xeg/ADB                  24 An adb wrapper to put in your crash dir
  1664. Xeg/README                1 Intro to example perl scripts
  1665. Xeg/changes              23 A program to list recently changed files
  1666. Xeg/down                 24 A program to do things to subdirectories
  1667. Xeg/dus                  24 A program to do du -s on non-mounted dirs
  1668. Xeg/findcp               17 A find wrapper that implements a -cp switch
  1669. Xeg/findtar              24 A find wrapper that pumps out a tar file
  1670. Xeg/g/gcp                22 A program to do a global rcp
  1671. Xeg/g/gcp.man            23 Manual page for gcp
  1672. Xeg/g/ged                24 A program to do a global edit
  1673. Xeg/g/ghosts             22 A sample /etc/ghosts file
  1674. Xeg/g/gsh                22 A program to do a global rsh
  1675. Xeg/g/gsh.man            21 Manual page for gsh
  1676. Xeg/muck                 22 A program to find missing make dependencies
  1677. Xeg/muck.man             24 Manual page for muck
  1678. Xeg/myrup                23 A program to find lightly loaded machines
  1679. Xeg/nih                  24 Script to insert #! workaround
  1680. Xeg/rename               24 A program to rename files
  1681. Xeg/rmfrom               24 A program to feed doomed filenames to
  1682. Xeg/scan/scan_df         23 Scan for filesystem anomalies
  1683. Xeg/scan/scan_last       23 Scan for login anomalies
  1684. Xeg/scan/scan_messages   21 Scan for console message anomalies
  1685. Xeg/scan/scan_passwd      6 Scan for passwd file anomalies
  1686. Xeg/scan/scan_ps         24 Scan for process anomalies
  1687. Xeg/scan/scan_sudo       23 Scan for sudo anomalies
  1688. Xeg/scan/scan_suid       22 Scan for setuid anomalies
  1689. Xeg/scan/scanner         23 An anomaly reporter
  1690. Xeg/shmkill              23 A program to remove unused shared memory
  1691. Xeg/van/empty            24 A program to empty the trashcan
  1692. Xeg/van/unvanish         23 A program to undo what vanish does
  1693. Xeg/van/vanexp           24 A program to expire vanished files
  1694. Xeg/van/vanish           23 A program to put files in a trashcan
  1695. Xeg/who                  24 A sample who program
  1696. Xeval.c                   3 The expression evaluator
  1697. Xevalargs.xc             19 The arg evaluator of eval.c
  1698. Xform.c                  20 Format processing
  1699. Xform.h                  24 Public declarations for the above
  1700. Xgettest                 24 A little script to test the get* routines
  1701. Xhandy.h                 22 Handy definitions
  1702. Xhash.c                  18 Associative arrays
  1703. Xhash.h                  23 Public declarations for the above
  1704. Xioctl.pl                21 Sample ioctl.pl
  1705. Xlib/abbrev.pl           24 An abbreviation table builder
  1706. Xlib/complete.pl         23 A command completion subroutine
  1707. Xlib/dumpvar.pl          24 A variable dumper
  1708. Xlib/getopt.pl           23 Perl library supporting option parsing
  1709. Xlib/getopts.pl          24 Perl library supporting option parsing
  1710. Xlib/importenv.pl        24 Perl routine to get environment into variables
  1711. Xlib/look.pl             23 A "look" equivalent
  1712. Xlib/perldb.pl           18 Perl debugging routines
  1713. Xlib/stat.pl             24 Perl library supporting stat function
  1714. Xlib/termcap.pl          22 Perl library supporting termcap usage
  1715. Xlib/validate.pl         21 Perl library supporting wholesale file mode validation
  1716. Xmakedepend.SH           21 Precursor to makedepend
  1717. Xmakedir.SH              23 Precursor to makedir
  1718. Xmakelib.SH              21 A thing to turn C .h file into perl .h files
  1719. Xmalloc.c                19 A version of malloc you might not want
  1720. Xpatchlevel.h            10 The current patch level of perl
  1721. Xperl.h                   8 Global declarations
  1722. Xperl.man.1               1 The manual page(s), first fourth
  1723. Xperl.man.2               9 The manual page(s), second fourth
  1724. Xperl.man.3               8 The manual page(s), third fourth
  1725. Xperl.man.4               6 The manual page(s), fourth fourth
  1726. Xperl.y                  12 Yacc grammar for perl
  1727. Xperlsh                  24 A poor man's perl shell
  1728. Xperly.c                 17 main()
  1729. Xregcomp.c               12 Regular expression compiler
  1730. Xregcomp.h                7 Private declarations for above
  1731. Xregexec.c               13 Regular expression evaluator
  1732. Xregexp.h                23 Public declarations for the above
  1733. Xserver                  24 A server to test sockets
  1734. Xspat.h                  23 Search pattern declarations
  1735. Xstab.c                   9 Symbol table stuff
  1736. Xstab.h                  20 Public declarations for the above
  1737. Xstr.c                   13 String handling package
  1738. Xstr.h                   14 Public declarations for the above
  1739. Xt/README                 1 Instructions for regression tests
  1740. Xt/TEST                  23 The regression tester
  1741. Xt/base.cond             24 See if conditionals work
  1742. Xt/base.if               24 See if if works
  1743. Xt/base.lex              23 See if lexical items work
  1744. Xt/base.pat              24 See if pattern matching works
  1745. Xt/base.term             24 See if various terms work
  1746. Xt/cmd.elsif             24 See if else-if works
  1747. Xt/cmd.for               23 See if for loops work
  1748. Xt/cmd.mod               24 See if statement modifiers work
  1749. Xt/cmd.subval            22 See if subroutine values work
  1750. Xt/cmd.switch            12 See if switch optimizations work
  1751. Xt/cmd.while             22 See if while loops work
  1752. Xt/comp.cmdopt           22 See if command optimization works
  1753. Xt/comp.cpp              24 See if C preprocessor works
  1754. Xt/comp.decl             24 See if declarations work
  1755. Xt/comp.multiline        24 See if multiline strings work
  1756. Xt/comp.package          24 See if packages work
  1757. Xt/comp.script           24 See if script invokation works
  1758. Xt/comp.term             23 See if more terms work
  1759. Xt/io.argv               23 See if ARGV stuff works
  1760. Xt/io.dup                24 See if >& works right
  1761. Xt/io.fs                 22 See if directory manipulations work
  1762. Xt/io.inplace            24 See if inplace editing works
  1763. Xt/io.pipe               24 See if secure pipes work
  1764. Xt/io.print              24 See if print commands work
  1765. Xt/io.tell               23 See if file seeking works
  1766. Xt/op.append             24 See if . works
  1767. Xt/op.array              22 See if array operations work
  1768. Xt/op.auto               18 See if autoincrement et all work
  1769. Xt/op.chop               24 See if chop works
  1770. Xt/op.cond               24 See if conditional expressions work
  1771. Xt/op.dbm                22 See if dbm binding works
  1772. Xt/op.delete             24 See if delete works
  1773. Xt/op.do                 23 See if subroutines work
  1774. Xt/op.each               23 See if associative iterators work
  1775. Xt/op.eval               23 See if eval operator works
  1776. Xt/op.exec               24 See if exec and system work
  1777. Xt/op.exp                 1 See if math functions work
  1778. Xt/op.flip               24 See if range operator works
  1779. Xt/op.fork               24 See if fork works
  1780. Xt/op.glob               24 See if <*> works
  1781. Xt/op.goto               24 See if goto works
  1782. Xt/op.index              24 See if index works
  1783. Xt/op.int                24 See if int works
  1784. Xt/op.join               24 See if join works
  1785. Xt/op.list               10 See if array lists work
  1786. Xt/op.local              24 See if local works
  1787. Xt/op.magic              23 See if magic variables work
  1788. Xt/op.mkdir              24 See if mkdir works
  1789. Xt/op.oct                24 See if oct and hex work
  1790. Xt/op.ord                24 See if ord works
  1791. Xt/op.pack               24 See if pack and unpack work
  1792. Xt/op.pat                22 See if esoteric patterns work
  1793. Xt/op.push               15 See if push and pop work
  1794. Xt/op.range              24 See if .. works
  1795. Xt/op.read               24 See if read() works
  1796. Xt/op.regexp             24 See if regular expressions work
  1797. Xt/op.repeat             23 See if x operator works
  1798. Xt/op.sleep               8 See if sleep works
  1799. Xt/op.sort               24 See if sort works
  1800. Xt/op.split              13 See if split works
  1801. Xt/op.sprintf            24 See if sprintf works
  1802. Xt/op.stat               21 See if stat works
  1803. Xt/op.study              23 See if study works
  1804. Xt/op.subst              21 See if substitutions work
  1805. Xt/op.substr             23 See if substr works
  1806. Xt/op.time               23 See if time functions work
  1807. Xt/op.undef              23 See if undef works
  1808. Xt/op.unshift            24 See if unshift works
  1809. Xt/op.vec                24 See if vectors work
  1810. Xt/op.write              23 See if write works
  1811. Xt/re_tests              22 Input file for op.regexp
  1812. Xtoke.c                   5 The tokener
  1813. Xutil.c                  17 Utility routines
  1814. Xutil.h                  24 Public declarations for the above
  1815. Xx2p/EXTERN.h            24 Same as above
  1816. Xx2p/INTERN.h            24 Same as above
  1817. Xx2p/Makefile.SH         22 Precursor to Makefile
  1818. Xx2p/a2p.h               20 Global declarations
  1819. Xx2p/a2p.man             20 Manual page for awk to perl translator
  1820. Xx2p/a2p.y               19 A yacc grammer for awk
  1821. Xx2p/a2py.c              16 Awk compiler, sort of
  1822. Xx2p/handy.h             24 Handy definitions
  1823. Xx2p/hash.c              21 Associative arrays again
  1824. Xx2p/hash.h              23 Public declarations for the above
  1825. Xx2p/s2p.SH              18 Sed to perl translator
  1826. Xx2p/s2p.man             22 Manual page for sed to perl translator
  1827. Xx2p/str.c               19 String handling package
  1828. Xx2p/str.h               23 Public declarations for the above
  1829. Xx2p/util.c              15 Utility routines
  1830. Xx2p/util.h              24 Public declarations for the above
  1831. Xx2p/walk.c               4 Parse tree walker
  1832. !STUFFY!FUNK!
  1833. echo Extracting t/op.auto
  1834. sed >t/op.auto <<'!STUFFY!FUNK!' -e 's/X//'
  1835. X#!./perl
  1836. X
  1837. X# $Header: op.auto,v 3.0 89/10/18 15:27:00 lwall Locked $
  1838. X
  1839. Xprint "1..34\n";
  1840. X
  1841. X$x = 10000;
  1842. Xif (0 + ++$x - 1 == 10000) { print "ok 1\n";} else {print "not ok 1\n";}
  1843. Xif (0 + $x-- - 1 == 10000) { print "ok 2\n";} else {print "not ok 2\n";}
  1844. Xif (1 * $x == 10000) { print "ok 3\n";} else {print "not ok 3\n";}
  1845. Xif (0 + $x-- - 0 == 10000) { print "ok 4\n";} else {print "not ok 4\n";}
  1846. Xif (1 + $x == 10000) { print "ok 5\n";} else {print "not ok 5\n";}
  1847. Xif (1 + $x++ == 10000) { print "ok 6\n";} else {print "not ok 6\n";}
  1848. Xif (0 + $x == 10000) { print "ok 7\n";} else {print "not ok 7\n";}
  1849. Xif (0 + --$x + 1 == 10000) { print "ok 8\n";} else {print "not ok 8\n";}
  1850. Xif (0 + ++$x + 0 == 10000) { print "ok 9\n";} else {print "not ok 9\n";}
  1851. Xif ($x == 10000) { print "ok 10\n";} else {print "not ok 10\n";}
  1852. X
  1853. X$x[0] = 10000;
  1854. Xif (0 + ++$x[0] - 1 == 10000) { print "ok 11\n";} else {print "not ok 11\n";}
  1855. Xif (0 + $x[0]-- - 1 == 10000) { print "ok 12\n";} else {print "not ok 12\n";}
  1856. Xif (1 * $x[0] == 10000) { print "ok 13\n";} else {print "not ok 13\n";}
  1857. Xif (0 + $x[0]-- - 0 == 10000) { print "ok 14\n";} else {print "not ok 14\n";}
  1858. Xif (1 + $x[0] == 10000) { print "ok 15\n";} else {print "not ok 15\n";}
  1859. Xif (1 + $x[0]++ == 10000) { print "ok 16\n";} else {print "not ok 16\n";}
  1860. Xif (0 + $x[0] == 10000) { print "ok 17\n";} else {print "not ok 17\n";}
  1861. Xif (0 + --$x[0] + 1 == 10000) { print "ok 18\n";} else {print "not ok 18\n";}
  1862. Xif (0 + ++$x[0] + 0 == 10000) { print "ok 19\n";} else {print "not ok 19\n";}
  1863. Xif ($x[0] == 10000) { print "ok 20\n";} else {print "not ok 20\n";}
  1864. X
  1865. X$x{0} = 10000;
  1866. Xif (0 + ++$x{0} - 1 == 10000) { print "ok 21\n";} else {print "not ok 21\n";}
  1867. Xif (0 + $x{0}-- - 1 == 10000) { print "ok 22\n";} else {print "not ok 22\n";}
  1868. Xif (1 * $x{0} == 10000) { print "ok 23\n";} else {print "not ok 23\n";}
  1869. Xif (0 + $x{0}-- - 0 == 10000) { print "ok 24\n";} else {print "not ok 24\n";}
  1870. Xif (1 + $x{0} == 10000) { print "ok 25\n";} else {print "not ok 25\n";}
  1871. Xif (1 + $x{0}++ == 10000) { print "ok 26\n";} else {print "not ok 26\n";}
  1872. Xif (0 + $x{0} == 10000) { print "ok 27\n";} else {print "not ok 27\n";}
  1873. Xif (0 + --$x{0} + 1 == 10000) { print "ok 28\n";} else {print "not ok 28\n";}
  1874. Xif (0 + ++$x{0} + 0 == 10000) { print "ok 29\n";} else {print "not ok 29\n";}
  1875. Xif ($x{0} == 10000) { print "ok 30\n";} else {print "not ok 30\n";}
  1876. X
  1877. X# test magical autoincrement
  1878. X
  1879. Xif (++($foo = '99') eq '100') {print "ok 31\n";} else {print "not ok 31\n";}
  1880. Xif (++($foo = 'a0') eq 'a1') {print "ok 32\n";} else {print "not ok 32\n";}
  1881. Xif (++($foo = 'Az') eq 'Ba') {print "ok 33\n";} else {print "not ok 33\n";}
  1882. Xif (++($foo = 'zz') eq 'aaa') {print "ok 34\n";} else {print "not ok 34\n";}
  1883. !STUFFY!FUNK!
  1884. echo ""
  1885. echo "End of kit 18 (of 24)"
  1886. cat /dev/null >kit18isdone
  1887. run=''
  1888. config=''
  1889. for iskit in 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24; do
  1890.     if test -f kit${iskit}isdone; then
  1891.     run="$run $iskit"
  1892.     else
  1893.     todo="$todo $iskit"
  1894.     fi
  1895. done
  1896. case $todo in
  1897.     '')
  1898.     echo "You have run all your kits.  Please read README and then type Configure."
  1899.     chmod 755 Configure
  1900.     ;;
  1901.     *)  echo "You have run$run."
  1902.     echo "You still need to run$todo."
  1903.     ;;
  1904. esac
  1905. : Someone might mail this, so...
  1906. exit
  1907.  
  1908.