home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1994 October / usenetsourcesnewsgroupsinfomagicoctober1994disk2.iso / misc / volume18 / perl / part28 < prev    next >
Internet Message Format  |  1991-04-17  |  51KB
  1. From: lwall@netlabs.com (Larry Wall)
  2. Newsgroups: comp.sources.misc
  3. Subject: v18i046:  perl - The perl programming language, Part28/36
  4. Message-ID: <1991Apr17.185804.2716@sparky.IMD.Sterling.COM>
  5. Date: 17 Apr 91 18:58:04 GMT
  6. Approved: kent@sparky.imd.sterling.com
  7. X-Checksum-Snefru: 03657332 3d003e3f 24df1865 1c5071a8
  8.  
  9. Submitted-by: Larry Wall <lwall@netlabs.com>
  10. Posting-number: Volume 18, Issue 46
  11. Archive-name: perl/part28
  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 28 (of 36).  If kit 28 is complete, the line"
  21. echo '"'"End of kit 28 (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 2>/dev/null
  25. echo Extracting os2/s2p.cmd
  26. sed >os2/s2p.cmd <<'!STUFFY!FUNK!' -e 's/X//'
  27. Xextproc perl -Sx
  28. X#!perl
  29. X
  30. X$bin = 'c:/bin';
  31. X
  32. X# $Header: s2p.cmd,v 4.0 91/03/20 01:37:09 lwall Locked $
  33. X#
  34. X# $Log:    s2p.cmd,v $
  35. X# Revision 4.0  91/03/20  01:37:09  lwall
  36. X# 4.0 baseline.
  37. X# 
  38. X# Revision 3.0.1.6  90/10/20  02:21:43  lwall
  39. X# patch37: changed some ". config.sh" to ". ./config.sh"
  40. X#
  41. X# Revision 3.0.1.5  90/10/16  11:32:40  lwall
  42. X# patch29: s2p modernized
  43. X#
  44. X# Revision 3.0.1.4  90/08/09  05:50:43  lwall
  45. X# patch19: s2p didn't translate \n right
  46. X#
  47. X# Revision 3.0.1.3  90/03/01  10:31:21  lwall
  48. X# patch9: s2p didn't handle \< and \>
  49. X#
  50. X# Revision 3.0.1.2  89/11/17  15:51:27  lwall
  51. X# patch5: in s2p, line labels without a subsequent statement were done wrong
  52. X# patch5: s2p left residue in /tmp
  53. X#
  54. X# Revision 3.0.1.1  89/11/11  05:08:25  lwall
  55. X# patch2: in s2p, + within patterns needed backslashing
  56. X# patch2: s2p was printing out some debugging info to the output file
  57. X#
  58. X# Revision 3.0  89/10/18  15:35:02  lwall
  59. X# 3.0 baseline
  60. X#
  61. X# Revision 2.0.1.1  88/07/11  23:26:23  root
  62. X# patch2: s2p didn't put a proper prologue on output script
  63. X#
  64. X# Revision 2.0  88/06/05  00:15:55  root
  65. X# Baseline version 2.0.
  66. X#
  67. X#
  68. X
  69. X$indent = 4;
  70. X$shiftwidth = 4;
  71. X$l = '{'; $r = '}';
  72. X
  73. Xwhile ($ARGV[0] =~ /^-/) {
  74. X    $_ = shift;
  75. X  last if /^--/;
  76. X    if (/^-D/) {
  77. X    $debug++;
  78. X    open(BODY,'>-');
  79. X    next;
  80. X    }
  81. X    if (/^-n/) {
  82. X    $assumen++;
  83. X    next;
  84. X    }
  85. X    if (/^-p/) {
  86. X    $assumep++;
  87. X    next;
  88. X    }
  89. X    die "I don't recognize this switch: $_\n";
  90. X}
  91. X
  92. Xunless ($debug) {
  93. X    open(BODY,">sperl$$") ||
  94. X      &Die("Can't open temp file: $!\n");
  95. X}
  96. X
  97. Xif (!$assumen && !$assumep) {
  98. X    print BODY <<'EOT';
  99. Xwhile ($ARGV[0] =~ /^-/) {
  100. X    $_ = shift;
  101. X  last if /^--/;
  102. X    if (/^-n/) {
  103. X    $nflag++;
  104. X    next;
  105. X    }
  106. X    die "I don't recognize this switch: $_\\n";
  107. X}
  108. X
  109. XEOT
  110. X}
  111. X
  112. Xprint BODY <<'EOT';
  113. X
  114. X#ifdef PRINTIT
  115. X#ifdef ASSUMEP
  116. X$printit++;
  117. X#else
  118. X$printit++ unless $nflag;
  119. X#endif
  120. X#endif
  121. XLINE: while (<>) {
  122. XEOT
  123. X
  124. XLINE: while (<>) {
  125. X
  126. X    # Wipe out surrounding whitespace.
  127. X
  128. X    s/[ \t]*(.*)\n$/$1/;
  129. X
  130. X    # Perhaps it's a label/comment.
  131. X
  132. X    if (/^:/) {
  133. X    s/^:[ \t]*//;
  134. X    $label = &make_label($_);
  135. X    if ($. == 1) {
  136. X        $toplabel = $label;
  137. X    }
  138. X    $_ = "$label:";
  139. X    if ($lastlinewaslabel++) {
  140. X        $indent += 4;
  141. X        print BODY &tab, ";\n";
  142. X        $indent -= 4;
  143. X    }
  144. X    if ($indent >= 2) {
  145. X        $indent -= 2;
  146. X        $indmod = 2;
  147. X    }
  148. X    next;
  149. X    } else {
  150. X    $lastlinewaslabel = '';
  151. X    }
  152. X
  153. X    # Look for one or two address clauses
  154. X
  155. X    $addr1 = '';
  156. X    $addr2 = '';
  157. X    if (s/^([0-9]+)//) {
  158. X    $addr1 = "$1";
  159. X    }
  160. X    elsif (s/^\$//) {
  161. X    $addr1 = 'eof()';
  162. X    }
  163. X    elsif (s|^/||) {
  164. X    $addr1 = &fetchpat('/');
  165. X    }
  166. X    if (s/^,//) {
  167. X    if (s/^([0-9]+)//) {
  168. X        $addr2 = "$1";
  169. X    } elsif (s/^\$//) {
  170. X        $addr2 = "eof()";
  171. X    } elsif (s|^/||) {
  172. X        $addr2 = &fetchpat('/');
  173. X    } else {
  174. X        &Die("Invalid second address at line $.\n");
  175. X    }
  176. X    $addr1 .= " .. $addr2";
  177. X    }
  178. X
  179. X    # Now we check for metacommands {, }, and ! and worry
  180. X    # about indentation.
  181. X
  182. X    s/^[ \t]+//;
  183. X    # a { to keep vi happy
  184. X    if ($_ eq '}') {
  185. X    $indent -= 4;
  186. X    next;
  187. X    }
  188. X    if (s/^!//) {
  189. X    $if = 'unless';
  190. X    $else = "$r else $l\n";
  191. X    } else {
  192. X    $if = 'if';
  193. X    $else = '';
  194. X    }
  195. X    if (s/^{//) {    # a } to keep vi happy
  196. X    $indmod = 4;
  197. X    $redo = $_;
  198. X    $_ = '';
  199. X    $rmaybe = '';
  200. X    } else {
  201. X    $rmaybe = "\n$r";
  202. X    if ($addr2 || $addr1) {
  203. X        $space = ' ' x $shiftwidth;
  204. X    } else {
  205. X        $space = '';
  206. X    }
  207. X    $_ = &transmogrify();
  208. X    }
  209. X
  210. X    # See if we can optimize to modifier form.
  211. X
  212. X    if ($addr1) {
  213. X    if ($_ !~ /[\n{}]/ && $rmaybe && !$change &&
  214. X      $_ !~ / if / && $_ !~ / unless /) {
  215. X        s/;$/ $if $addr1;/;
  216. X        $_ = substr($_,$shiftwidth,1000);
  217. X    } else {
  218. X        $_ = "$if ($addr1) $l\n$change$_$rmaybe";
  219. X    }
  220. X    $change = '';
  221. X    next LINE;
  222. X    }
  223. X} continue {
  224. X    @lines = split(/\n/,$_);
  225. X    for (@lines) {
  226. X    unless (s/^ *<<--//) {
  227. X        print BODY &tab;
  228. X    }
  229. X    print BODY $_, "\n";
  230. X    }
  231. X    $indent += $indmod;
  232. X    $indmod = 0;
  233. X    if ($redo) {
  234. X    $_ = $redo;
  235. X    $redo = '';
  236. X    redo LINE;
  237. X    }
  238. X}
  239. Xif ($lastlinewaslabel++) {
  240. X    $indent += 4;
  241. X    print BODY &tab, ";\n";
  242. X    $indent -= 4;
  243. X}
  244. X
  245. Xprint BODY "}\n";
  246. Xif ($appendseen || $tseen || !$assumen) {
  247. X    $printit++ if $dseen || (!$assumen && !$assumep);
  248. X    print BODY <<'EOT';
  249. X
  250. Xcontinue {
  251. X#ifdef PRINTIT
  252. X#ifdef DSEEN
  253. X#ifdef ASSUMEP
  254. X    print if $printit++;
  255. X#else
  256. X    if ($printit)
  257. X    { print; }
  258. X    else
  259. X    { $printit++ unless $nflag; }
  260. X#endif
  261. X#else
  262. X    print if $printit;
  263. X#endif
  264. X#else
  265. X    print;
  266. X#endif
  267. X#ifdef TSEEN
  268. X    $tflag = '';
  269. X#endif
  270. X#ifdef APPENDSEEN
  271. X    if ($atext) { print $atext; $atext = ''; }
  272. X#endif
  273. X}
  274. XEOT
  275. X}
  276. X
  277. Xclose BODY;
  278. X
  279. Xunless ($debug) {
  280. X    open(HEAD,">sperl2$$.c")
  281. X      || &Die("Can't open temp file 2: $!\n");
  282. X    print HEAD "#define PRINTIT\n" if ($printit);
  283. X    print HEAD "#define APPENDSEEN\n" if ($appendseen);
  284. X    print HEAD "#define TSEEN\n" if ($tseen);
  285. X    print HEAD "#define DSEEN\n" if ($dseen);
  286. X    print HEAD "#define ASSUMEN\n" if ($assumen);
  287. X    print HEAD "#define ASSUMEP\n" if ($assumep);
  288. X    if ($opens) {print HEAD "$opens\n";}
  289. X    open(BODY,"sperl$$")
  290. X      || &Die("Can't reopen temp file: $!\n");
  291. X    while (<BODY>) {
  292. X    print HEAD $_;
  293. X    }
  294. X    close HEAD;
  295. X
  296. X    print <<"EOT";
  297. X#!$bin/perl
  298. Xeval 'exec $bin/perl -S \$0 \$*'
  299. X    if \$running_under_some_shell;
  300. X
  301. XEOT
  302. X    open(BODY,"cc -E sperl2$$.c |") ||
  303. X    &Die("Can't reopen temp file: $!\n");
  304. X    while (<BODY>) {
  305. X    /^# [0-9]/ && next;
  306. X    /^[ \t]*$/ && next;
  307. X    s/^<><>//;
  308. X    print;
  309. X    }
  310. X}
  311. X
  312. X&Cleanup;
  313. Xexit;
  314. X
  315. Xsub Cleanup {
  316. X    unlink "sperl$$", "sperl2$$", "sperl2$$.c";
  317. X}
  318. Xsub Die {
  319. X    &Cleanup;
  320. X    die $_[0];
  321. X}
  322. Xsub tab {
  323. X    "\t" x ($indent / 8) . ' ' x ($indent % 8);
  324. X}
  325. Xsub make_filehandle {
  326. X    local($_) = $_[0];
  327. X    local($fname) = $_;
  328. X    s/[^a-zA-Z]/_/g;
  329. X    s/^_*//;
  330. X    substr($_,0,1) =~ y/a-z/A-Z/ if /^[a-z]/;
  331. X    if (!$seen{$_}) {
  332. X    $opens .= <<"EOT";
  333. Xopen($_,'>$fname') || die "Can't create $fname";
  334. XEOT
  335. X    }
  336. X    $seen{$_} = $_;
  337. X}
  338. X
  339. Xsub make_label {
  340. X    local($label) = @_;
  341. X    $label =~ s/[^a-zA-Z0-9]/_/g;
  342. X    if ($label =~ /^[0-9_]/) { $label = 'L' . $label; }
  343. X    $label = substr($label,0,8);
  344. X
  345. X    # Could be a reserved word, so capitalize it.
  346. X    substr($label,0,1) =~ y/a-z/A-Z/
  347. X      if $label =~ /^[a-z]/;
  348. X
  349. X    $label;
  350. X}
  351. X
  352. Xsub transmogrify {
  353. X    {    # case
  354. X    if (/^d/) {
  355. X        $dseen++;
  356. X        chop($_ = <<'EOT');
  357. X<<--#ifdef PRINTIT
  358. X$printit = '';
  359. X<<--#endif
  360. Xnext LINE;
  361. XEOT
  362. X        next;
  363. X    }
  364. X
  365. X    if (/^n/) {
  366. X        chop($_ = <<'EOT');
  367. X<<--#ifdef PRINTIT
  368. X<<--#ifdef DSEEN
  369. X<<--#ifdef ASSUMEP
  370. Xprint if $printit++;
  371. X<<--#else
  372. Xif ($printit)
  373. X    { print; }
  374. Xelse
  375. X    { $printit++ unless $nflag; }
  376. X<<--#endif
  377. X<<--#else
  378. Xprint if $printit;
  379. X<<--#endif
  380. X<<--#else
  381. Xprint;
  382. X<<--#endif
  383. X<<--#ifdef APPENDSEEN
  384. Xif ($atext) {print $atext; $atext = '';}
  385. X<<--#endif
  386. X$_ = <>;
  387. X<<--#ifdef TSEEN
  388. X$tflag = '';
  389. X<<--#endif
  390. XEOT
  391. X        next;
  392. X    }
  393. X
  394. X    if (/^a/) {
  395. X        $appendseen++;
  396. X        $command = $space . '$atext .=' . "\n<<--'";
  397. X        $lastline = 0;
  398. X        while (<>) {
  399. X        s/^[ \t]*//;
  400. X        s/^[\\]//;
  401. X        unless (s|\\$||) { $lastline = 1;}
  402. X        s/'/\\'/g;
  403. X        s/^([ \t]*\n)/<><>$1/;
  404. X        $command .= $_;
  405. X        $command .= '<<--';
  406. X        last if $lastline;
  407. X        }
  408. X        $_ = $command . "';";
  409. X        last;
  410. X    }
  411. X
  412. X    if (/^[ic]/) {
  413. X        if (/^c/) { $change = 1; }
  414. X        $addr1 = '$iter = (' . $addr1 . ')';
  415. X        $command = $space . 'if ($iter == 1) { print'
  416. X          . "\n<<--'";
  417. X        $lastline = 0;
  418. X        while (<>) {
  419. X        s/^[ \t]*//;
  420. X        s/^[\\]//;
  421. X        unless (s/\\$//) { $lastline = 1;}
  422. X        s/'/\\'/g;
  423. X        s/^([ \t]*\n)/<><>$1/;
  424. X        $command .= $_;
  425. X        $command .= '<<--';
  426. X        last if $lastline;
  427. X        }
  428. X        $_ = $command . "';}";
  429. X        if ($change) {
  430. X        $dseen++;
  431. X        $change = "$_\n";
  432. X        chop($_ = <<"EOT");
  433. X<<--#ifdef PRINTIT
  434. X$space\$printit = '';
  435. X<<--#endif
  436. X${space}next LINE;
  437. XEOT
  438. X        }
  439. X        last;
  440. X    }
  441. X
  442. X    if (/^s/) {
  443. X        $delim = substr($_,1,1);
  444. X        $len = length($_);
  445. X        $repl = $end = 0;
  446. X        $inbracket = 0;
  447. X        for ($i = 2; $i < $len; $i++) {
  448. X        $c = substr($_,$i,1);
  449. X        if ($c eq $delim) {
  450. X            if ($inbracket) {
  451. X            substr($_, $i, 0) = '\\';
  452. X            $i++;
  453. X            $len++;
  454. X            }
  455. X            else {
  456. X            if ($repl) {
  457. X                $end = $i;
  458. X                last;
  459. X            } else {
  460. X                $repl = $i;
  461. X            }
  462. X            }
  463. X        }
  464. X        elsif ($c eq '\\') {
  465. X            $i++;
  466. X            if ($i >= $len) {
  467. X            $_ .= 'n';
  468. X            $_ .= <>;
  469. X            $len = length($_);
  470. X            $_ = substr($_,0,--$len);
  471. X            }
  472. X            elsif (substr($_,$i,1) =~ /^[n]$/) {
  473. X            ;
  474. X            }
  475. X            elsif (!$repl &&
  476. X              substr($_,$i,1) =~ /^[(){}\w]$/) {
  477. X            $i--;
  478. X            $len--;
  479. X            substr($_, $i, 1) = '';
  480. X            }
  481. X            elsif (!$repl &&
  482. X              substr($_,$i,1) =~ /^[<>]$/) {
  483. X            substr($_,$i,1) = 'b';
  484. X            }
  485. X        }
  486. X        elsif ($c eq '[' && !$repl) {
  487. X            $i++ if substr($_,$i,1) eq '^';
  488. X            $i++ if substr($_,$i,1) eq ']';
  489. X            $inbracket = 1;
  490. X        }
  491. X        elsif ($c eq ']') {
  492. X            $inbracket = 0;
  493. X        }
  494. X        elsif (!$repl && index("()+",$c) >= 0) {
  495. X            substr($_, $i, 0) = '\\';
  496. X            $i++;
  497. X            $len++;
  498. X        }
  499. X        }
  500. X        &Die("Malformed substitution at line $.\n")
  501. X          unless $end;
  502. X        $pat = substr($_, 0, $repl + 1);
  503. X        $repl = substr($_, $repl+1, $end-$repl-1);
  504. X        $end = substr($_, $end + 1, 1000);
  505. X        $dol = '$';
  506. X        $repl =~ s/\$/\\$/;
  507. X        $repl =~ s'&'$&'g;
  508. X        $repl =~ s/[\\]([0-9])/$dol$1/g;
  509. X        $subst = "$pat$repl$delim";
  510. X        $cmd = '';
  511. X        while ($end) {
  512. X        if ($end =~ s/^g//) {
  513. X            $subst .= 'g';
  514. X            next;
  515. X        }
  516. X        if ($end =~ s/^p//) {
  517. X            $cmd .= ' && (print)';
  518. X            next;
  519. X        }
  520. X        if ($end =~ s/^w[ \t]*//) {
  521. X            $fh = &make_filehandle($end);
  522. X            $cmd .= " && (print $fh \$_)";
  523. X            $end = '';
  524. X            next;
  525. X        }
  526. X        &Die("Unrecognized substitution command".
  527. X          "($end) at line $.\n");
  528. X        }
  529. X        chop ($_ = <<"EOT");
  530. X<<--#ifdef TSEEN
  531. X$subst && \$tflag++$cmd;
  532. X<<--#else
  533. X$subst$cmd;
  534. X<<--#endif
  535. XEOT
  536. X        next;
  537. X    }
  538. X
  539. X    if (/^p/) {
  540. X        $_ = 'print;';
  541. X        next;
  542. X    }
  543. X
  544. X    if (/^w/) {
  545. X        s/^w[ \t]*//;
  546. X        $fh = &make_filehandle($_);
  547. X        $_ = "print $fh \$_;";
  548. X        next;
  549. X    }
  550. X
  551. X    if (/^r/) {
  552. X        $appendseen++;
  553. X        s/^r[ \t]*//;
  554. X        $file = $_;
  555. X        $_ = "\$atext .= `cat $file 2>/dev/null`;";
  556. X        next;
  557. X    }
  558. X
  559. X    if (/^P/) {
  560. X        $_ = 'print $1 if /(^.*\n)/;';
  561. X        next;
  562. X    }
  563. X
  564. X    if (/^D/) {
  565. X        chop($_ = <<'EOT');
  566. Xs/^.*\n//;
  567. Xredo LINE if $_;
  568. Xnext LINE;
  569. XEOT
  570. X        next;
  571. X    }
  572. X
  573. X    if (/^N/) {
  574. X        chop($_ = <<'EOT');
  575. X$_ .= <>;
  576. X<<--#ifdef TSEEN
  577. X$tflag = '';
  578. X<<--#endif
  579. XEOT
  580. X        next;
  581. X    }
  582. X
  583. X    if (/^h/) {
  584. X        $_ = '$hold = $_;';
  585. X        next;
  586. X    }
  587. X
  588. X    if (/^H/) {
  589. X        $_ = '$hold .= $_ ? $_ : "\n";';
  590. X        next;
  591. X    }
  592. X
  593. X    if (/^g/) {
  594. X        $_ = '$_ = $hold;';
  595. X        next;
  596. X    }
  597. X
  598. X    if (/^G/) {
  599. X        $_ = '$_ .= $hold ? $hold : "\n";';
  600. X        next;
  601. X    }
  602. X
  603. X    if (/^x/) {
  604. X        $_ = '($_, $hold) = ($hold, $_);';
  605. X        next;
  606. X    }
  607. X
  608. X    if (/^b$/) {
  609. X        $_ = 'next LINE;';
  610. X        next;
  611. X    }
  612. X
  613. X    if (/^b/) {
  614. X        s/^b[ \t]*//;
  615. X        $lab = &make_label($_);
  616. X        if ($lab eq $toplabel) {
  617. X        $_ = 'redo LINE;';
  618. X        } else {
  619. X        $_ = "goto $lab;";
  620. X        }
  621. X        next;
  622. X    }
  623. X
  624. X    if (/^t$/) {
  625. X        $_ = 'next LINE if $tflag;';
  626. X        $tseen++;
  627. X        next;
  628. X    }
  629. X
  630. X    if (/^t/) {
  631. X        s/^t[ \t]*//;
  632. X        $lab = &make_label($_);
  633. X        $_ = q/if ($tflag) {$tflag = ''; /;
  634. X        if ($lab eq $toplabel) {
  635. X        $_ .= 'redo LINE;}';
  636. X        } else {
  637. X        $_ .= "goto $lab;}";
  638. X        }
  639. X        $tseen++;
  640. X        next;
  641. X    }
  642. X
  643. X    if (/^=/) {
  644. X        $_ = 'print "$.\n";';
  645. X        next;
  646. X    }
  647. X
  648. X    if (/^q/) {
  649. X        chop($_ = <<'EOT');
  650. Xclose(ARGV);
  651. X@ARGV = ();
  652. Xnext LINE;
  653. XEOT
  654. X        next;
  655. X    }
  656. X    } continue {
  657. X    if ($space) {
  658. X        s/^/$space/;
  659. X        s/(\n)(.)/$1$space$2/g;
  660. X    }
  661. X    last;
  662. X    }
  663. X    $_;
  664. X}
  665. X
  666. Xsub fetchpat {
  667. X    local($outer) = @_;
  668. X    local($addr) = $outer;
  669. X    local($inbracket);
  670. X    local($prefix,$delim,$ch);
  671. X
  672. X    # Process pattern one potential delimiter at a time.
  673. X
  674. X    DELIM: while (s#^([^\]+(|)[\\/]*)([]+(|)[\\/])##) {
  675. X    $prefix = $1;
  676. X    $delim = $2;
  677. X    if ($delim eq '\\') {
  678. X        s/(.)//;
  679. X        $ch = $1;
  680. X        $delim = '' if $ch =~ /^[(){}A-Za-mo-z]$/;
  681. X        $ch = 'b' if $ch =~ /^[<>]$/;
  682. X        $delim .= $ch;
  683. X    }
  684. X    elsif ($delim eq '[') {
  685. X        $inbracket = 1;
  686. X        s/^\^// && ($delim .= '^');
  687. X        s/^]// && ($delim .= ']');
  688. X    }
  689. X    elsif ($delim eq ']') {
  690. X        $inbracket = 0;
  691. X    }
  692. X    elsif ($inbracket || $delim ne $outer) {
  693. X        $delim = '\\' . $delim;
  694. X    }
  695. X    $addr .= $prefix;
  696. X    $addr .= $delim;
  697. X    if ($delim eq $outer && !$inbracket) {
  698. X        last DELIM;
  699. X    }
  700. X    }
  701. X    $addr;
  702. X}
  703. !STUFFY!FUNK!
  704. echo Extracting doio.c:AB
  705. sed >doio.c:AB <<'!STUFFY!FUNK!' -e 's/X//'
  706. X        }
  707. X        else {
  708. X        while (items--) {
  709. X            if (kill((int)(str_gnum(st[++sp])),val))
  710. X            tot--;
  711. X        }
  712. X        }
  713. X    }
  714. X    break;
  715. X#endif
  716. X    case O_UNLINK:
  717. X#ifdef TAINT
  718. X    taintproper("Insecure dependency in unlink");
  719. X#endif
  720. X    tot = items;
  721. X    while (items--) {
  722. X        s = str_get(st[++sp]);
  723. X        if (euid || unsafe) {
  724. X        if (UNLINK(s))
  725. X            tot--;
  726. X        }
  727. X        else {    /* don't let root wipe out directories without -U */
  728. X#ifdef HAS_LSTAT
  729. X        if (lstat(s,&statbuf) < 0 || S_ISDIR(statbuf.st_mode))
  730. X#else
  731. X        if (stat(s,&statbuf) < 0 || S_ISDIR(statbuf.st_mode))
  732. X#endif
  733. X            tot--;
  734. X        else {
  735. X            if (UNLINK(s))
  736. X            tot--;
  737. X        }
  738. X        }
  739. X    }
  740. X    break;
  741. X    case O_UTIME:
  742. X#ifdef TAINT
  743. X    taintproper("Insecure dependency in utime");
  744. X#endif
  745. X    if (items > 2) {
  746. X#ifdef I_UTIME
  747. X        struct utimbuf utbuf;
  748. X#else
  749. X        struct {
  750. X        long    actime;
  751. X        long    modtime;
  752. X        } utbuf;
  753. X#endif
  754. X
  755. X        Zero(&utbuf, sizeof utbuf, char);
  756. X        utbuf.actime = (long)str_gnum(st[++sp]);    /* time accessed */
  757. X        utbuf.modtime = (long)str_gnum(st[++sp]);    /* time modified */
  758. X        items -= 2;
  759. X#ifndef lint
  760. X        tot = items;
  761. X        while (items--) {
  762. X        if (utime(str_get(st[++sp]),&utbuf))
  763. X            tot--;
  764. X        }
  765. X#endif
  766. X    }
  767. X    else
  768. X        items = 0;
  769. X    break;
  770. X    }
  771. X    return tot;
  772. X}
  773. X
  774. X/* Do the permissions allow some operation?  Assumes statcache already set. */
  775. X
  776. Xint
  777. Xcando(bit, effective, statbufp)
  778. Xint bit;
  779. Xint effective;
  780. Xregister struct stat *statbufp;
  781. X{
  782. X#ifdef MSDOS
  783. X    /* [Comments and code from Len Reed]
  784. X     * MS-DOS "user" is similar to UNIX's "superuser," but can't write
  785. X     * to write-protected files.  The execute permission bit is set
  786. X     * by the Miscrosoft C library stat() function for the following:
  787. X     *        .exe files
  788. X     *        .com files
  789. X     *        .bat files
  790. X     *        directories
  791. X     * All files and directories are readable.
  792. X     * Directories and special files, e.g. "CON", cannot be
  793. X     * write-protected.
  794. X     * [Comment by Tom Dinger -- a directory can have the write-protect
  795. X     *        bit set in the file system, but DOS permits changes to
  796. X     *        the directory anyway.  In addition, all bets are off
  797. X     *        here for networked software, such as Novell and
  798. X     *        Sun's PC-NFS.]
  799. X     */
  800. X
  801. X     return (bit & statbufp->st_mode) ? TRUE : FALSE;
  802. X
  803. X#else /* ! MSDOS */
  804. X    if ((effective ? euid : uid) == 0) {    /* root is special */
  805. X    if (bit == S_IXUSR) {
  806. X        if (statbufp->st_mode & 0111 || S_ISDIR(statbufp->st_mode))
  807. X        return TRUE;
  808. X    }
  809. X    else
  810. X        return TRUE;        /* root reads and writes anything */
  811. X    return FALSE;
  812. X    }
  813. X    if (statbufp->st_uid == (effective ? euid : uid) ) {
  814. X    if (statbufp->st_mode & bit)
  815. X        return TRUE;    /* ok as "user" */
  816. X    }
  817. X    else if (ingroup((int)statbufp->st_gid,effective)) {
  818. X    if (statbufp->st_mode & bit >> 3)
  819. X        return TRUE;    /* ok as "group" */
  820. X    }
  821. X    else if (statbufp->st_mode & bit >> 6)
  822. X    return TRUE;    /* ok as "other" */
  823. X    return FALSE;
  824. X#endif /* ! MSDOS */
  825. X}
  826. X
  827. Xint
  828. Xingroup(testgid,effective)
  829. Xint testgid;
  830. Xint effective;
  831. X{
  832. X    if (testgid == (effective ? egid : gid))
  833. X    return TRUE;
  834. X#ifdef HAS_GETGROUPS
  835. X#ifndef NGROUPS
  836. X#define NGROUPS 32
  837. X#endif
  838. X    {
  839. X    GROUPSTYPE gary[NGROUPS];
  840. X    int anum;
  841. X
  842. X    anum = getgroups(NGROUPS,gary);
  843. X    while (--anum >= 0)
  844. X        if (gary[anum] == testgid)
  845. X        return TRUE;
  846. X    }
  847. X#endif
  848. X    return FALSE;
  849. X}
  850. X
  851. X#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
  852. X
  853. Xint
  854. Xdo_ipcget(optype, arglast)
  855. Xint optype;
  856. Xint *arglast;
  857. X{
  858. X    register STR **st = stack->ary_array;
  859. X    register int sp = arglast[0];
  860. X    key_t key;
  861. X    int n, flags;
  862. X
  863. X    key = (key_t)str_gnum(st[++sp]);
  864. X    n = (optype == O_MSGGET) ? 0 : (int)str_gnum(st[++sp]);
  865. X    flags = (int)str_gnum(st[++sp]);
  866. X    errno = 0;
  867. X    switch (optype)
  868. X    {
  869. X#ifdef HAS_MSG
  870. X    case O_MSGGET:
  871. X    return msgget(key, flags);
  872. X#endif
  873. X#ifdef HAS_SEM
  874. X    case O_SEMGET:
  875. X    return semget(key, n, flags);
  876. X#endif
  877. X#ifdef HAS_SHM
  878. X    case O_SHMGET:
  879. X    return shmget(key, n, flags);
  880. X#endif
  881. X#if !defined(HAS_MSG) || !defined(HAS_SEM) || !defined(HAS_SHM)
  882. X    default:
  883. X    fatal("%s not implemented", opname[optype]);
  884. X#endif
  885. X    }
  886. X    return -1;            /* should never happen */
  887. X}
  888. X
  889. Xint
  890. Xdo_ipcctl(optype, arglast)
  891. Xint optype;
  892. Xint *arglast;
  893. X{
  894. X    register STR **st = stack->ary_array;
  895. X    register int sp = arglast[0];
  896. X    STR *astr;
  897. X    char *a;
  898. X    int id, n, cmd, infosize, getinfo, ret;
  899. X
  900. X    id = (int)str_gnum(st[++sp]);
  901. X    n = (optype == O_SEMCTL) ? (int)str_gnum(st[++sp]) : 0;
  902. X    cmd = (int)str_gnum(st[++sp]);
  903. X    astr = st[++sp];
  904. X
  905. X    infosize = 0;
  906. X    getinfo = (cmd == IPC_STAT);
  907. X
  908. X    switch (optype)
  909. X    {
  910. X#ifdef HAS_MSG
  911. X    case O_MSGCTL:
  912. X    if (cmd == IPC_STAT || cmd == IPC_SET)
  913. X        infosize = sizeof(struct msqid_ds);
  914. X    break;
  915. X#endif
  916. X#ifdef HAS_SHM
  917. X    case O_SHMCTL:
  918. X    if (cmd == IPC_STAT || cmd == IPC_SET)
  919. X        infosize = sizeof(struct shmid_ds);
  920. X    break;
  921. X#endif
  922. X#ifdef HAS_SEM
  923. X    case O_SEMCTL:
  924. X    if (cmd == IPC_STAT || cmd == IPC_SET)
  925. X        infosize = sizeof(struct semid_ds);
  926. X    else if (cmd == GETALL || cmd == SETALL)
  927. X    {
  928. X        struct semid_ds semds;
  929. X        if (semctl(id, 0, IPC_STAT, &semds) == -1)
  930. X        return -1;
  931. X        getinfo = (cmd == GETALL);
  932. X#ifdef _POSIX_SOURCE
  933. X        infosize = semds.sem_nsems * sizeof(ushort_t);
  934. X#else
  935. X        infosize = semds.sem_nsems * sizeof(ushort);
  936. X#endif
  937. X    }
  938. X    break;
  939. X#endif
  940. X#if !defined(HAS_MSG) || !defined(HAS_SEM) || !defined(HAS_SHM)
  941. X    default:
  942. X    fatal("%s not implemented", opname[optype]);
  943. X#endif
  944. X    }
  945. X
  946. X    if (infosize)
  947. X    {
  948. X    if (getinfo)
  949. X    {
  950. X        STR_GROW(astr, infosize+1);
  951. X        a = str_get(astr);
  952. X    }
  953. X    else
  954. X    {
  955. X        a = str_get(astr);
  956. X        if (astr->str_cur != infosize)
  957. X        {
  958. X        errno = EINVAL;
  959. X        return -1;
  960. X        }
  961. X    }
  962. X    }
  963. X    else
  964. X    {
  965. X    int i = (int)str_gnum(astr);
  966. X    a = (char *)i;        /* ouch */
  967. X    }
  968. X    errno = 0;
  969. X    switch (optype)
  970. X    {
  971. X#ifdef HAS_MSG
  972. X    case O_MSGCTL:
  973. X    ret = msgctl(id, cmd, a);
  974. X    break;
  975. X#endif
  976. X#ifdef HAS_SEM
  977. X    case O_SEMCTL:
  978. X    ret = semctl(id, n, cmd, a);
  979. X    break;
  980. X#endif
  981. X#ifdef HAS_SHM
  982. X    case O_SHMCTL:
  983. X    ret = shmctl(id, cmd, a);
  984. X    break;
  985. X#endif
  986. X    }
  987. X    if (getinfo && ret >= 0) {
  988. X    astr->str_cur = infosize;
  989. X    astr->str_ptr[infosize] = '\0';
  990. X    }
  991. X    return ret;
  992. X}
  993. X
  994. Xint
  995. Xdo_msgsnd(arglast)
  996. Xint *arglast;
  997. X{
  998. X#ifdef HAS_MSG
  999. X    register STR **st = stack->ary_array;
  1000. X    register int sp = arglast[0];
  1001. X    STR *mstr;
  1002. X    char *mbuf;
  1003. X    int id, msize, flags;
  1004. X
  1005. X    id = (int)str_gnum(st[++sp]);
  1006. X    mstr = st[++sp];
  1007. X    flags = (int)str_gnum(st[++sp]);
  1008. X    mbuf = str_get(mstr);
  1009. X    if ((msize = mstr->str_cur - sizeof(long)) < 0) {
  1010. X    errno = EINVAL;
  1011. X    return -1;
  1012. X    }
  1013. X    errno = 0;
  1014. X    return msgsnd(id, mbuf, msize, flags);
  1015. X#else
  1016. X    fatal("msgsnd not implemented");
  1017. X#endif
  1018. X}
  1019. X
  1020. Xint
  1021. Xdo_msgrcv(arglast)
  1022. Xint *arglast;
  1023. X{
  1024. X#ifdef HAS_MSG
  1025. X    register STR **st = stack->ary_array;
  1026. X    register int sp = arglast[0];
  1027. X    STR *mstr;
  1028. X    char *mbuf;
  1029. X    long mtype;
  1030. X    int id, msize, flags, ret;
  1031. X
  1032. X    id = (int)str_gnum(st[++sp]);
  1033. X    mstr = st[++sp];
  1034. X    msize = (int)str_gnum(st[++sp]);
  1035. X    mtype = (long)str_gnum(st[++sp]);
  1036. X    flags = (int)str_gnum(st[++sp]);
  1037. X    mbuf = str_get(mstr);
  1038. X    if (mstr->str_cur < sizeof(long)+msize+1) {
  1039. X    STR_GROW(mstr, sizeof(long)+msize+1);
  1040. X    mbuf = str_get(mstr);
  1041. X    }
  1042. X    errno = 0;
  1043. X    ret = msgrcv(id, mbuf, msize, mtype, flags);
  1044. X    if (ret >= 0) {
  1045. X    mstr->str_cur = sizeof(long)+ret;
  1046. X    mstr->str_ptr[sizeof(long)+ret] = '\0';
  1047. X    }
  1048. X    return ret;
  1049. X#else
  1050. X    fatal("msgrcv not implemented");
  1051. X#endif
  1052. X}
  1053. X
  1054. Xint
  1055. Xdo_semop(arglast)
  1056. Xint *arglast;
  1057. X{
  1058. X#ifdef HAS_SEM
  1059. X    register STR **st = stack->ary_array;
  1060. X    register int sp = arglast[0];
  1061. X    STR *opstr;
  1062. X    char *opbuf;
  1063. X    int id, opsize;
  1064. X
  1065. X    id = (int)str_gnum(st[++sp]);
  1066. X    opstr = st[++sp];
  1067. X    opbuf = str_get(opstr);
  1068. X    opsize = opstr->str_cur;
  1069. X    if (opsize < sizeof(struct sembuf)
  1070. X    || (opsize % sizeof(struct sembuf)) != 0) {
  1071. X    errno = EINVAL;
  1072. X    return -1;
  1073. X    }
  1074. X    errno = 0;
  1075. X    return semop(id, opbuf, opsize/sizeof(struct sembuf));
  1076. X#else
  1077. X    fatal("semop not implemented");
  1078. X#endif
  1079. X}
  1080. X
  1081. Xint
  1082. Xdo_shmio(optype, arglast)
  1083. Xint optype;
  1084. Xint *arglast;
  1085. X{
  1086. X#ifdef HAS_SHM
  1087. X    register STR **st = stack->ary_array;
  1088. X    register int sp = arglast[0];
  1089. X    STR *mstr;
  1090. X    char *mbuf, *shm;
  1091. X    int id, mpos, msize;
  1092. X    struct shmid_ds shmds;
  1093. X    extern char *shmat();
  1094. X
  1095. X    id = (int)str_gnum(st[++sp]);
  1096. X    mstr = st[++sp];
  1097. X    mpos = (int)str_gnum(st[++sp]);
  1098. X    msize = (int)str_gnum(st[++sp]);
  1099. X    errno = 0;
  1100. X    if (shmctl(id, IPC_STAT, &shmds) == -1)
  1101. X    return -1;
  1102. X    if (mpos < 0 || msize < 0 || mpos + msize > shmds.shm_segsz) {
  1103. X    errno = EFAULT;        /* can't do as caller requested */
  1104. X    return -1;
  1105. X    }
  1106. X    shm = shmat(id, (char *)NULL, (optype == O_SHMREAD) ? SHM_RDONLY : 0);
  1107. X    if (shm == (char *)-1)    /* I hate System V IPC, I really do */
  1108. X    return -1;
  1109. X    mbuf = str_get(mstr);
  1110. X    if (optype == O_SHMREAD) {
  1111. X    if (mstr->str_cur < msize) {
  1112. X        STR_GROW(mstr, msize+1);
  1113. X        mbuf = str_get(mstr);
  1114. X    }
  1115. X    bcopy(shm + mpos, mbuf, msize);
  1116. X    mstr->str_cur = msize;
  1117. X    mstr->str_ptr[msize] = '\0';
  1118. X    }
  1119. X    else {
  1120. X    int n;
  1121. X
  1122. X    if ((n = mstr->str_cur) > msize)
  1123. X        n = msize;
  1124. X    bcopy(mbuf, shm + mpos, n);
  1125. X    if (n < msize)
  1126. X        bzero(shm + mpos + n, msize - n);
  1127. X    }
  1128. X    return shmdt(shm);
  1129. X#else
  1130. X    fatal("shm I/O not implemented");
  1131. X#endif
  1132. X}
  1133. X
  1134. X#endif /* SYSV IPC */
  1135. !STUFFY!FUNK!
  1136. echo Extracting toke.c:AB
  1137. sed >toke.c:AB <<'!STUFFY!FUNK!' -e 's/X//'
  1138. X            oldoldbufptr = oldbufptr = bufptr = s = str_get(linestr);
  1139. X            bufend = linestr->str_ptr + linestr->str_cur;
  1140. X            hereis = FALSE;
  1141. X        }
  1142. X        else
  1143. X            str_nset(tmpstr,"",0);   /* avoid "uninitialized" warning */
  1144. X        }
  1145. X        else
  1146. X        s = str_append_till(tmpstr,s+1,bufend,term,leave);
  1147. X        while (s >= bufend) {    /* multiple line string? */
  1148. X        if (!rsfp ||
  1149. X         !(oldoldbufptr = oldbufptr = s = str_gets(linestr, rsfp, 0))) {
  1150. X            curcmd->c_line = multi_start;
  1151. X            fatal("EOF in string");
  1152. X        }
  1153. X        curcmd->c_line++;
  1154. X        if (perldb) {
  1155. X            STR *str = Str_new(88,0);
  1156. X
  1157. X            str_sset(str,linestr);
  1158. X            astore(stab_xarray(curcmd->c_filestab),
  1159. X              (int)curcmd->c_line,str);
  1160. X        }
  1161. X        bufend = linestr->str_ptr + linestr->str_cur;
  1162. X        if (hereis) {
  1163. X            if (*s == term && bcmp(s,tokenbuf,len) == 0) {
  1164. X            s = bufend - 1;
  1165. X            *s = ' ';
  1166. X            str_scat(linestr,herewas);
  1167. X            bufend = linestr->str_ptr + linestr->str_cur;
  1168. X            }
  1169. X            else {
  1170. X            s = bufend;
  1171. X            str_scat(tmpstr,linestr);
  1172. X            }
  1173. X        }
  1174. X        else
  1175. X            s = str_append_till(tmpstr,s,bufend,term,leave);
  1176. X        }
  1177. X        multi_end = curcmd->c_line;
  1178. X        s++;
  1179. X        if (tmpstr->str_cur + 5 < tmpstr->str_len) {
  1180. X        tmpstr->str_len = tmpstr->str_cur + 1;
  1181. X        Renew(tmpstr->str_ptr, tmpstr->str_len, char);
  1182. X        }
  1183. X        if ((arg[1].arg_type & A_MASK) == A_SINGLE) {
  1184. X        arg[1].arg_ptr.arg_str = tmpstr;
  1185. X        break;
  1186. X        }
  1187. X        tmps = s;
  1188. X        s = tmpstr->str_ptr;
  1189. X        send = s + tmpstr->str_cur;
  1190. X        while (s < send) {        /* see if we can make SINGLE */
  1191. X        if (*s == '\\' && s[1] && isdigit(s[1]) && !isdigit(s[2]) &&
  1192. X          !alwaysdollar && s[1] != '0')
  1193. X            *s = '$';        /* grandfather \digit in subst */
  1194. X        if ((*s == '$' || *s == '@') && s+1 < send &&
  1195. X          (alwaysdollar || (s[1] != ')' && s[1] != '|'))) {
  1196. X            makesingle = FALSE;    /* force interpretation */
  1197. X        }
  1198. X        else if (*s == '\\' && s+1 < send) {
  1199. X            if (index("lLuUE",s[1]))
  1200. X            makesingle = FALSE;
  1201. X            s++;
  1202. X        }
  1203. X        s++;
  1204. X        }
  1205. X        s = d = tmpstr->str_ptr;    /* assuming shrinkage only */
  1206. X        while (s < send) {
  1207. X        if ((*s == '$' && s+1 < send &&
  1208. X            (alwaysdollar || /*(*/ (s[1] != ')' && s[1] != '|')) ) ||
  1209. X            (*s == '@' && s+1 < send) ) {
  1210. X            len = scanident(s,send,tokenbuf) - s;
  1211. X            if (*s == '$' || strEQ(tokenbuf,"ARGV")
  1212. X              || strEQ(tokenbuf,"ENV")
  1213. X              || strEQ(tokenbuf,"SIG")
  1214. X              || strEQ(tokenbuf,"INC") )
  1215. X            (void)stabent(tokenbuf,TRUE); /* make sure it exists */
  1216. X            while (len--)
  1217. X            *d++ = *s++;
  1218. X            continue;
  1219. X        }
  1220. X        else if (*s == '\\' && s+1 < send) {
  1221. X            s++;
  1222. X            switch (*s) {
  1223. X            default:
  1224. X            if (!makesingle && (!leave || (*s && index(leave,*s))))
  1225. X                *d++ = '\\';
  1226. X            *d++ = *s++;
  1227. X            continue;
  1228. X            case '0': case '1': case '2': case '3':
  1229. X            case '4': case '5': case '6': case '7':
  1230. X            *d++ = scanoct(s, 3, &len);
  1231. X            s += len;
  1232. X            continue;
  1233. X            case 'x':
  1234. X            *d++ = scanhex(++s, 2, &len);
  1235. X            s += len;
  1236. X            continue;
  1237. X            case 'c':
  1238. X            s++;
  1239. X            *d = *s++;
  1240. X            if (islower(*d))
  1241. X                *d = toupper(*d);
  1242. X            *d++ ^= 64;
  1243. X            continue;
  1244. X            case 'b':
  1245. X            *d++ = '\b';
  1246. X            break;
  1247. X            case 'n':
  1248. X            *d++ = '\n';
  1249. X            break;
  1250. X            case 'r':
  1251. X            *d++ = '\r';
  1252. X            break;
  1253. X            case 'f':
  1254. X            *d++ = '\f';
  1255. X            break;
  1256. X            case 't':
  1257. X            *d++ = '\t';
  1258. X            break;
  1259. X            case 'e':
  1260. X            *d++ = '\033';
  1261. X            break;
  1262. X            case 'a':
  1263. X            *d++ = '\007';
  1264. X            break;
  1265. X            }
  1266. X            s++;
  1267. X            continue;
  1268. X        }
  1269. X        *d++ = *s++;
  1270. X        }
  1271. X        *d = '\0';
  1272. X
  1273. X        if ((arg[1].arg_type & A_MASK) == A_DOUBLE && makesingle)
  1274. X            arg[1].arg_type = A_SINGLE;    /* now we can optimize on it */
  1275. X
  1276. X        tmpstr->str_cur = d - tmpstr->str_ptr;
  1277. X        arg[1].arg_ptr.arg_str = tmpstr;
  1278. X        s = tmps;
  1279. X        break;
  1280. X    }
  1281. X    }
  1282. X    if (hereis)
  1283. X    str_free(herewas);
  1284. X    return s;
  1285. X}
  1286. X
  1287. XFCMD *
  1288. Xload_format()
  1289. X{
  1290. X    FCMD froot;
  1291. X    FCMD *flinebeg;
  1292. X    char *eol;
  1293. X    register FCMD *fprev = &froot;
  1294. X    register FCMD *fcmd;
  1295. X    register char *s;
  1296. X    register char *t;
  1297. X    register STR *str;
  1298. X    bool noblank;
  1299. X    bool repeater;
  1300. X
  1301. X    Zero(&froot, 1, FCMD);
  1302. X    s = bufptr;
  1303. X    while (s < bufend || (rsfp && (s = str_gets(linestr,rsfp, 0)) != Nullch)) {
  1304. X    curcmd->c_line++;
  1305. X    if (in_eval && !rsfp) {
  1306. X        eol = index(s,'\n');
  1307. X        if (!eol++)
  1308. X        eol = bufend;
  1309. X    }
  1310. X    else
  1311. X        eol = bufend = linestr->str_ptr + linestr->str_cur;
  1312. X    if (perldb) {
  1313. X        STR *tmpstr = Str_new(89,0);
  1314. X
  1315. X        str_nset(tmpstr, s, eol-s);
  1316. X        astore(stab_xarray(curcmd->c_filestab), (int)curcmd->c_line,tmpstr);
  1317. X    }
  1318. X    if (*s == '.') {
  1319. X        for (t = s+1; *t == ' ' || *t == '\t'; t++) ;
  1320. X        if (*t == '\n') {
  1321. X        bufptr = s;
  1322. X        return froot.f_next;
  1323. X        }
  1324. X    }
  1325. X    if (*s == '#') {
  1326. X        s = eol;
  1327. X        continue;
  1328. X    }
  1329. X    flinebeg = Nullfcmd;
  1330. X    noblank = FALSE;
  1331. X    repeater = FALSE;
  1332. X    while (s < eol) {
  1333. X        Newz(804,fcmd,1,FCMD);
  1334. X        fprev->f_next = fcmd;
  1335. X        fprev = fcmd;
  1336. X        for (t=s; t < eol && *t != '@' && *t != '^'; t++) {
  1337. X        if (*t == '~') {
  1338. X            noblank = TRUE;
  1339. X            *t = ' ';
  1340. X            if (t[1] == '~') {
  1341. X            repeater = TRUE;
  1342. X            t[1] = ' ';
  1343. X            }
  1344. X        }
  1345. X        }
  1346. X        fcmd->f_pre = nsavestr(s, t-s);
  1347. X        fcmd->f_presize = t-s;
  1348. X        s = t;
  1349. X        if (s >= eol) {
  1350. X        if (noblank)
  1351. X            fcmd->f_flags |= FC_NOBLANK;
  1352. X        if (repeater)
  1353. X            fcmd->f_flags |= FC_REPEAT;
  1354. X        break;
  1355. X        }
  1356. X        if (!flinebeg)
  1357. X        flinebeg = fcmd;        /* start values here */
  1358. X        if (*s++ == '^')
  1359. X        fcmd->f_flags |= FC_CHOP;    /* for doing text filling */
  1360. X        switch (*s) {
  1361. X        case '*':
  1362. X        fcmd->f_type = F_LINES;
  1363. X        *s = '\0';
  1364. X        break;
  1365. X        case '<':
  1366. X        fcmd->f_type = F_LEFT;
  1367. X        while (*s == '<')
  1368. X            s++;
  1369. X        break;
  1370. X        case '>':
  1371. X        fcmd->f_type = F_RIGHT;
  1372. X        while (*s == '>')
  1373. X            s++;
  1374. X        break;
  1375. X        case '|':
  1376. X        fcmd->f_type = F_CENTER;
  1377. X        while (*s == '|')
  1378. X            s++;
  1379. X        break;
  1380. X        case '#':
  1381. X        case '.':
  1382. X        /* Catch the special case @... and handle it as a string
  1383. X           field. */
  1384. X        if (*s == '.' && s[1] == '.') {
  1385. X            goto default_format;
  1386. X        }
  1387. X        fcmd->f_type = F_DECIMAL;
  1388. X        {
  1389. X            char *p;
  1390. X
  1391. X            /* Read a format in the form @####.####, where either group
  1392. X               of ### may be empty, or the final .### may be missing. */
  1393. X            while (*s == '#')
  1394. X            s++;
  1395. X            if (*s == '.') {
  1396. X            s++;
  1397. X            p = s;
  1398. X            while (*s == '#')
  1399. X                s++;
  1400. X            fcmd->f_decimals = s-p;
  1401. X            fcmd->f_flags |= FC_DP;
  1402. X            } else {
  1403. X            fcmd->f_decimals = 0;
  1404. X            }
  1405. X        }
  1406. X        break;
  1407. X        default:
  1408. X        default_format:
  1409. X        fcmd->f_type = F_LEFT;
  1410. X        break;
  1411. X        }
  1412. X        if (fcmd->f_flags & FC_CHOP && *s == '.') {
  1413. X        fcmd->f_flags |= FC_MORE;
  1414. X        while (*s == '.')
  1415. X            s++;
  1416. X        }
  1417. X        fcmd->f_size = s-t;
  1418. X    }
  1419. X    if (flinebeg) {
  1420. X      again:
  1421. X        if (s >= bufend &&
  1422. X          (!rsfp || (s = str_gets(linestr, rsfp, 0)) == Nullch) )
  1423. X        goto badform;
  1424. X        curcmd->c_line++;
  1425. X        if (in_eval && !rsfp) {
  1426. X        eol = index(s,'\n');
  1427. X        if (!eol++)
  1428. X            eol = bufend;
  1429. X        }
  1430. X        else
  1431. X        eol = bufend = linestr->str_ptr + linestr->str_cur;
  1432. X        if (perldb) {
  1433. X        STR *tmpstr = Str_new(90,0);
  1434. X
  1435. X        str_nset(tmpstr, s, eol-s);
  1436. X        astore(stab_xarray(curcmd->c_filestab),
  1437. X            (int)curcmd->c_line,tmpstr);
  1438. X        }
  1439. X        if (strnEQ(s,".\n",2)) {
  1440. X        bufptr = s;
  1441. X        yyerror("Missing values line");
  1442. X        return froot.f_next;
  1443. X        }
  1444. X        if (*s == '#') {
  1445. X        s = eol;
  1446. X        goto again;
  1447. X        }
  1448. X        str = flinebeg->f_unparsed = Str_new(91,eol - s);
  1449. X        str->str_u.str_hash = curstash;
  1450. X        str_nset(str,"(",1);
  1451. X        flinebeg->f_line = curcmd->c_line;
  1452. X        eol[-1] = '\0';
  1453. X        if (!flinebeg->f_next->f_type || index(s, ',')) {
  1454. X        eol[-1] = '\n';
  1455. X        str_ncat(str, s, eol - s - 1);
  1456. X        str_ncat(str,",$$);",5);
  1457. X        s = eol;
  1458. X        }
  1459. X        else {
  1460. X        eol[-1] = '\n';
  1461. X        while (s < eol && isspace(*s))
  1462. X            s++;
  1463. X        t = s;
  1464. X        while (s < eol) {
  1465. X            switch (*s) {
  1466. X            case ' ': case '\t': case '\n': case ';':
  1467. X            str_ncat(str, t, s - t);
  1468. X            str_ncat(str, "," ,1);
  1469. X            while (s < eol && (isspace(*s) || *s == ';'))
  1470. X                s++;
  1471. X            t = s;
  1472. X            break;
  1473. X            case '$':
  1474. X            str_ncat(str, t, s - t);
  1475. X            t = s;
  1476. X            s = scanident(s,eol,tokenbuf);
  1477. X            str_ncat(str, t, s - t);
  1478. X            t = s;
  1479. X            if (s < eol && *s && index("$'\"",*s))
  1480. X                str_ncat(str, ",", 1);
  1481. X            break;
  1482. X            case '"': case '\'':
  1483. X            str_ncat(str, t, s - t);
  1484. X            t = s;
  1485. X            s++;
  1486. X            while (s < eol && (*s != *t || s[-1] == '\\'))
  1487. X                s++;
  1488. X            if (s < eol)
  1489. X                s++;
  1490. X            str_ncat(str, t, s - t);
  1491. X            t = s;
  1492. X            if (s < eol && *s && index("$'\"",*s))
  1493. X                str_ncat(str, ",", 1);
  1494. X            break;
  1495. X            default:
  1496. X            yyerror("Please use commas to separate fields");
  1497. X            }
  1498. X        }
  1499. X        str_ncat(str,"$$);",4);
  1500. X        }
  1501. X    }
  1502. X    }
  1503. X  badform:
  1504. X    bufptr = str_get(linestr);
  1505. X    yyerror("Format not terminated");
  1506. X    return froot.f_next;
  1507. X}
  1508. X
  1509. Xset_csh()
  1510. X{
  1511. X#ifdef CSH
  1512. X    if (!cshlen)
  1513. X    cshlen = strlen(cshname);
  1514. X#endif
  1515. X}
  1516. !STUFFY!FUNK!
  1517. echo Extracting form.c
  1518. sed >form.c <<'!STUFFY!FUNK!' -e 's/X//'
  1519. X/* $Header: form.c,v 4.0 91/03/20 01:19:23 lwall Locked $
  1520. X *
  1521. X *    Copyright (c) 1989, Larry Wall
  1522. X *
  1523. X *    You may distribute under the terms of the GNU General Public License
  1524. X *    as specified in the README file that comes with the perl 3.0 kit.
  1525. X *
  1526. X * $Log:    form.c,v $
  1527. X * Revision 4.0  91/03/20  01:19:23  lwall
  1528. X * 4.0 baseline.
  1529. X * 
  1530. X */
  1531. X
  1532. X#include "EXTERN.h"
  1533. X#include "perl.h"
  1534. X
  1535. X/* Forms stuff */
  1536. X
  1537. Xvoid
  1538. Xform_parseargs(fcmd)
  1539. Xregister FCMD *fcmd;
  1540. X{
  1541. X    register int i;
  1542. X    register ARG *arg;
  1543. X    register int items;
  1544. X    STR *str;
  1545. X    ARG *parselist();
  1546. X    line_t oldline = curcmd->c_line;
  1547. X    int oldsave = savestack->ary_fill;
  1548. X
  1549. X    str = fcmd->f_unparsed;
  1550. X    curcmd->c_line = fcmd->f_line;
  1551. X    fcmd->f_unparsed = Nullstr;
  1552. X    (void)savehptr(&curstash);
  1553. X    curstash = str->str_u.str_hash;
  1554. X    arg = parselist(str);
  1555. X    restorelist(oldsave);
  1556. X
  1557. X    items = arg->arg_len - 1;    /* ignore $$ on end */
  1558. X    for (i = 1; i <= items; i++) {
  1559. X    if (!fcmd || fcmd->f_type == F_NULL)
  1560. X        fatal("Too many field values");
  1561. X    dehoist(arg,i);
  1562. X    fcmd->f_expr = make_op(O_ITEM,1,
  1563. X      arg[i].arg_ptr.arg_arg,Nullarg,Nullarg);
  1564. X    if (fcmd->f_flags & FC_CHOP) {
  1565. X        if ((fcmd->f_expr[1].arg_type & A_MASK) == A_STAB)
  1566. X        fcmd->f_expr[1].arg_type = A_LVAL;
  1567. X        else if ((fcmd->f_expr[1].arg_type & A_MASK) == A_EXPR)
  1568. X        fcmd->f_expr[1].arg_type = A_LEXPR;
  1569. X        else
  1570. X        fatal("^ field requires scalar lvalue");
  1571. X    }
  1572. X    fcmd = fcmd->f_next;
  1573. X    }
  1574. X    if (fcmd && fcmd->f_type)
  1575. X    fatal("Not enough field values");
  1576. X    curcmd->c_line = oldline;
  1577. X    Safefree(arg);
  1578. X    str_free(str);
  1579. X}
  1580. X
  1581. Xint newsize;
  1582. X
  1583. X#define CHKLEN(allow) \
  1584. Xnewsize = (d - orec->o_str) + (allow); \
  1585. Xif (newsize >= curlen) { \
  1586. X    curlen = d - orec->o_str; \
  1587. X    GROWSTR(&orec->o_str,&orec->o_len,orec->o_len + (allow)); \
  1588. X    d = orec->o_str + curlen;    /* in case it moves */ \
  1589. X    curlen = orec->o_len - 2; \
  1590. X}
  1591. X
  1592. Xformat(orec,fcmd,sp)
  1593. Xregister struct outrec *orec;
  1594. Xregister FCMD *fcmd;
  1595. Xint sp;
  1596. X{
  1597. X    register char *d = orec->o_str;
  1598. X    register char *s;
  1599. X    register int curlen = orec->o_len - 2;
  1600. X    register int size;
  1601. X    FCMD *nextfcmd;
  1602. X    FCMD *linebeg = fcmd;
  1603. X    char tmpchar;
  1604. X    char *t;
  1605. X    CMD mycmd;
  1606. X    STR *str;
  1607. X    char *chophere;
  1608. X
  1609. X    mycmd.c_type = C_NULL;
  1610. X    orec->o_lines = 0;
  1611. X    for (; fcmd; fcmd = nextfcmd) {
  1612. X    nextfcmd = fcmd->f_next;
  1613. X    CHKLEN(fcmd->f_presize);
  1614. X    if (s = fcmd->f_pre) {
  1615. X        while (*s) {
  1616. X        if (*s == '\n') {
  1617. X            while (d > orec->o_str && (d[-1] == ' ' || d[-1] == '\t'))
  1618. X            d--;
  1619. X            if (fcmd->f_flags & FC_NOBLANK) {
  1620. X            if (d == orec->o_str || d[-1] == '\n') {
  1621. X                orec->o_lines--;    /* don't print blank line */
  1622. X                linebeg = fcmd->f_next;
  1623. X                break;
  1624. X            }
  1625. X            else if (fcmd->f_flags & FC_REPEAT)
  1626. X                nextfcmd = linebeg;
  1627. X            else
  1628. X                linebeg = fcmd->f_next;
  1629. X            }
  1630. X            else
  1631. X            linebeg = fcmd->f_next;
  1632. X        }
  1633. X        *d++ = *s++;
  1634. X        }
  1635. X    }
  1636. X    if (fcmd->f_unparsed)
  1637. X        form_parseargs(fcmd);
  1638. X    switch (fcmd->f_type) {
  1639. X    case F_NULL:
  1640. X        orec->o_lines++;
  1641. X        break;
  1642. X    case F_LEFT:
  1643. X        (void)eval(fcmd->f_expr,G_SCALAR,sp);
  1644. X        str = stack->ary_array[sp+1];
  1645. X        s = str_get(str);
  1646. X        size = fcmd->f_size;
  1647. X        CHKLEN(size);
  1648. X        chophere = Nullch;
  1649. X        while (size && *s && *s != '\n') {
  1650. X        if (*s == '\t')
  1651. X            *s = ' ';
  1652. X        size--;
  1653. X        if (*s && index(chopset,(*d++ = *s++)))
  1654. X            chophere = s;
  1655. X        if (*s == '\n' && (fcmd->f_flags & FC_CHOP))
  1656. X            *s = ' ';
  1657. X        }
  1658. X        if (size)
  1659. X        chophere = s;
  1660. X        else if (chophere && chophere < s && *s && index(chopset,*s))
  1661. X        chophere = s;
  1662. X        if (fcmd->f_flags & FC_CHOP) {
  1663. X        if (!chophere)
  1664. X            chophere = s;
  1665. X        size += (s - chophere);
  1666. X        d -= (s - chophere);
  1667. X        if (fcmd->f_flags & FC_MORE &&
  1668. X          *chophere && strNE(chophere,"\n")) {
  1669. X            while (size < 3) {
  1670. X            d--;
  1671. X            size++;
  1672. X            }
  1673. X            while (d[-1] == ' ' && size < fcmd->f_size) {
  1674. X            d--;
  1675. X            size++;
  1676. X            }
  1677. X            *d++ = '.';
  1678. X            *d++ = '.';
  1679. X            *d++ = '.';
  1680. X            size -= 3;
  1681. X        }
  1682. X        while (*chophere && index(chopset,*chophere))
  1683. X            chophere++;
  1684. X        str_chop(str,chophere);
  1685. X        }
  1686. X        if (fcmd->f_next && fcmd->f_next->f_pre[0] == '\n')
  1687. X        size = 0;            /* no spaces before newline */
  1688. X        while (size) {
  1689. X        size--;
  1690. X        *d++ = ' ';
  1691. X        }
  1692. X        break;
  1693. X    case F_RIGHT:
  1694. X        (void)eval(fcmd->f_expr,G_SCALAR,sp);
  1695. X        str = stack->ary_array[sp+1];
  1696. X        t = s = str_get(str);
  1697. X        size = fcmd->f_size;
  1698. X        CHKLEN(size);
  1699. X        chophere = Nullch;
  1700. X        while (size && *s && *s != '\n') {
  1701. X        if (*s == '\t')
  1702. X            *s = ' ';
  1703. X        size--;
  1704. X        if (*s && index(chopset,*s++))
  1705. X            chophere = s;
  1706. X        if (*s == '\n' && (fcmd->f_flags & FC_CHOP))
  1707. X            *s = ' ';
  1708. X        }
  1709. X        if (size)
  1710. X        chophere = s;
  1711. X        else if (chophere && chophere < s && *s && index(chopset,*s))
  1712. X        chophere = s;
  1713. X        if (fcmd->f_flags & FC_CHOP) {
  1714. X        if (!chophere)
  1715. X            chophere = s;
  1716. X        size += (s - chophere);
  1717. X        s = chophere;
  1718. X        while (*chophere && index(chopset,*chophere))
  1719. X            chophere++;
  1720. X        }
  1721. X        tmpchar = *s;
  1722. X        *s = '\0';
  1723. X        while (size) {
  1724. X        size--;
  1725. X        *d++ = ' ';
  1726. X        }
  1727. X        size = s - t;
  1728. X        (void)bcopy(t,d,size);
  1729. X        d += size;
  1730. X        *s = tmpchar;
  1731. X        if (fcmd->f_flags & FC_CHOP)
  1732. X        str_chop(str,chophere);
  1733. X        break;
  1734. X    case F_CENTER: {
  1735. X        int halfsize;
  1736. X
  1737. X        (void)eval(fcmd->f_expr,G_SCALAR,sp);
  1738. X        str = stack->ary_array[sp+1];
  1739. X        t = s = str_get(str);
  1740. X        size = fcmd->f_size;
  1741. X        CHKLEN(size);
  1742. X        chophere = Nullch;
  1743. X        while (size && *s && *s != '\n') {
  1744. X        if (*s == '\t')
  1745. X            *s = ' ';
  1746. X        size--;
  1747. X        if (*s && index(chopset,*s++))
  1748. X            chophere = s;
  1749. X        if (*s == '\n' && (fcmd->f_flags & FC_CHOP))
  1750. X            *s = ' ';
  1751. X        }
  1752. X        if (size)
  1753. X        chophere = s;
  1754. X        else if (chophere && chophere < s && *s && index(chopset,*s))
  1755. X        chophere = s;
  1756. X        if (fcmd->f_flags & FC_CHOP) {
  1757. X        if (!chophere)
  1758. X            chophere = s;
  1759. X        size += (s - chophere);
  1760. X        s = chophere;
  1761. X        while (*chophere && index(chopset,*chophere))
  1762. X            chophere++;
  1763. X        }
  1764. X        tmpchar = *s;
  1765. X        *s = '\0';
  1766. X        halfsize = size / 2;
  1767. X        while (size > halfsize) {
  1768. X        size--;
  1769. X        *d++ = ' ';
  1770. X        }
  1771. X        size = s - t;
  1772. X        (void)bcopy(t,d,size);
  1773. X        d += size;
  1774. X        *s = tmpchar;
  1775. X        if (fcmd->f_next && fcmd->f_next->f_pre[0] == '\n')
  1776. X        size = 0;            /* no spaces before newline */
  1777. X        else
  1778. X        size = halfsize;
  1779. X        while (size) {
  1780. X        size--;
  1781. X        *d++ = ' ';
  1782. X        }
  1783. X        if (fcmd->f_flags & FC_CHOP)
  1784. X        str_chop(str,chophere);
  1785. X        break;
  1786. X    }
  1787. X    case F_LINES:
  1788. X        (void)eval(fcmd->f_expr,G_SCALAR,sp);
  1789. X        str = stack->ary_array[sp+1];
  1790. X        s = str_get(str);
  1791. X        size = str_len(str);
  1792. X        CHKLEN(size+1);
  1793. X        orec->o_lines += countlines(s,size) - 1;
  1794. X        (void)bcopy(s,d,size);
  1795. X        d += size;
  1796. X        if (size && s[size-1] != '\n') {
  1797. X        *d++ = '\n';
  1798. X        orec->o_lines++;
  1799. X        }
  1800. X        linebeg = fcmd->f_next;
  1801. X        break;
  1802. X    case F_DECIMAL: {
  1803. X        double value;
  1804. X
  1805. X        (void)eval(fcmd->f_expr,G_SCALAR,sp);
  1806. X        str = stack->ary_array[sp+1];
  1807. X        size = fcmd->f_size;
  1808. X        CHKLEN(size);
  1809. X        /* If the field is marked with ^ and the value is undefined,
  1810. X           blank it out. */
  1811. X        if ((fcmd->f_flags & FC_CHOP) && !str->str_pok && !str->str_nok) {
  1812. X        while (size) {
  1813. X            size--;
  1814. X            *d++ = ' ';
  1815. X        }
  1816. X        break;
  1817. X        }
  1818. X        value = str_gnum(str);
  1819. X        if (fcmd->f_flags & FC_DP) {
  1820. X        sprintf(d, "%#*.*f", size, fcmd->f_decimals, value);
  1821. X        } else {
  1822. X        sprintf(d, "%*.0f", size, value);
  1823. X        }
  1824. X        d += size;
  1825. X        break;
  1826. X    }
  1827. X    }
  1828. X    }
  1829. X    CHKLEN(1);
  1830. X    *d++ = '\0';
  1831. X}
  1832. X
  1833. Xcountlines(s,size)
  1834. Xregister char *s;
  1835. Xregister int size;
  1836. X{
  1837. X    register int count = 0;
  1838. X
  1839. X    while (size--) {
  1840. X    if (*s++ == '\n')
  1841. X        count++;
  1842. X    }
  1843. X    return count;
  1844. X}
  1845. X
  1846. Xdo_write(orec,stio,sp)
  1847. Xstruct outrec *orec;
  1848. Xregister STIO *stio;
  1849. Xint sp;
  1850. X{
  1851. X    FILE *ofp = stio->ofp;
  1852. X
  1853. X#ifdef DEBUGGING
  1854. X    if (debug & 256)
  1855. X    fprintf(stderr,"left=%ld, todo=%ld\n",
  1856. X      (long)stio->lines_left, (long)orec->o_lines);
  1857. X#endif
  1858. X    if (stio->lines_left < orec->o_lines) {
  1859. X    if (!stio->top_stab) {
  1860. X        STAB *topstab;
  1861. X
  1862. X        if (!stio->top_name)
  1863. X        stio->top_name = savestr("top");
  1864. X        topstab = stabent(stio->top_name,FALSE);
  1865. X        if (!topstab || !stab_form(topstab)) {
  1866. X        stio->lines_left = 100000000;
  1867. X        goto forget_top;
  1868. X        }
  1869. X        stio->top_stab = topstab;
  1870. X    }
  1871. X    if (stio->lines_left >= 0 && stio->page > 0)
  1872. X        (void)putc('\f',ofp);
  1873. X    stio->lines_left = stio->page_len;
  1874. X    stio->page++;
  1875. X    format(&toprec,stab_form(stio->top_stab),sp);
  1876. X    fputs(toprec.o_str,ofp);
  1877. X    stio->lines_left -= toprec.o_lines;
  1878. X    }
  1879. X  forget_top:
  1880. X    fputs(orec->o_str,ofp);
  1881. X    stio->lines_left -= orec->o_lines;
  1882. X}
  1883. !STUFFY!FUNK!
  1884. echo Extracting Makefile.SH
  1885. sed >Makefile.SH <<'!STUFFY!FUNK!' -e 's/X//'
  1886. Xcase $CONFIG in
  1887. X'')
  1888. X    if test ! -f config.sh; then
  1889. X    ln ../config.sh . || \
  1890. X    ln ../../config.sh . || \
  1891. X    ln ../../../config.sh . || \
  1892. X    (echo "Can't find config.sh."; exit 1)
  1893. X    fi 2>/dev/null
  1894. X    . ./config.sh
  1895. X    ;;
  1896. Xesac
  1897. Xcase "$0" in
  1898. X*/*) cd `expr X$0 : 'X\(.*\)/'` ;;
  1899. Xesac
  1900. X
  1901. Xcase "$d_symlink" in
  1902. X*define*) sln='ln -s' ;;
  1903. X*) sln='ln';;
  1904. Xesac
  1905. X
  1906. Xcase "$d_dosuid" in
  1907. X*define*) suidperl='suidperl' ;;
  1908. X*) suidperl='';;
  1909. Xesac
  1910. X
  1911. Xecho "Extracting Makefile (with variable substitutions)"
  1912. Xcat >Makefile <<!GROK!THIS!
  1913. X# $RCSfile: Makefile.SH,v $$Revision: 4.0.1.1 $$Date: 91/04/11 17:30:39 $
  1914. X#
  1915. X# $Log:    Makefile.SH,v $
  1916. X# Revision 4.0.1.1  91/04/11  17:30:39  lwall
  1917. X# patch1: C flags are now settable on a per-file basis
  1918. X# 
  1919. X# Revision 4.0  91/03/20  00:58:54  lwall
  1920. X# 4.0 baseline.
  1921. X# 
  1922. X# 
  1923. X
  1924. XCC = $cc
  1925. XYACC = $yacc
  1926. Xbin = $installbin
  1927. Xscriptdir = $scriptdir
  1928. Xprivlib = $installprivlib
  1929. Xmansrc = $mansrc
  1930. Xmanext = $manext
  1931. XLDFLAGS = $ldflags
  1932. XCLDFLAGS = $ldflags
  1933. XSMALL = $small
  1934. XLARGE = $large $split
  1935. Xmallocsrc = $mallocsrc
  1936. Xmallocobj = $mallocobj
  1937. XSLN = $sln
  1938. X
  1939. Xlibs = $libs $cryptlib
  1940. X
  1941. Xpublic = perl taintperl $suidperl
  1942. X
  1943. X!GROK!THIS!
  1944. X
  1945. Xcat >>Makefile <<'!NO!SUBS!'
  1946. X
  1947. XCFLAGS = `sh cflags.SH $@`
  1948. X
  1949. Xprivate = 
  1950. X
  1951. Xscripts = h2ph
  1952. X
  1953. XMAKE = make
  1954. X
  1955. Xmanpages = perl.man h2ph.man
  1956. X
  1957. Xutil =
  1958. X
  1959. Xsh = Makefile.SH makedepend.SH h2ph.SH
  1960. X
  1961. Xh1 = EXTERN.h INTERN.h arg.h array.h cmd.h config.h form.h handy.h
  1962. Xh2 = hash.h perl.h regcomp.h regexp.h spat.h stab.h str.h util.h
  1963. X
  1964. Xh = $(h1) $(h2)
  1965. X
  1966. Xc1 = array.c cmd.c cons.c consarg.c doarg.c doio.c dolist.c dump.c
  1967. Xc2 = eval.c form.c hash.c $(mallocsrc) perl.c regcomp.c regexec.c
  1968. Xc3 = stab.c str.c toke.c util.c usersub.c
  1969. X
  1970. Xc = $(c1) $(c2) $(c3)
  1971. X
  1972. Xobj1 = array.o cmd.o cons.o consarg.o doarg.o doio.o dolist.o dump.o
  1973. Xobj2 = eval.o form.o hash.o $(mallocobj) perl.o regcomp.o regexec.o
  1974. Xobj3 = stab.o str.o toke.o util.o
  1975. X
  1976. Xobj = $(obj1) $(obj2) $(obj3)
  1977. X
  1978. Xtobj1 = tarray.o tcmd.o tcons.o tconsarg.o tdoarg.o tdoio.o tdolist.o tdump.o
  1979. Xtobj2 = teval.o tform.o thash.o $(mallocobj) tregcomp.o tregexec.o
  1980. Xtobj3 = tstab.o tstr.o ttoke.o tutil.o
  1981. X
  1982. Xtobj = $(tobj1) $(tobj2) $(tobj3)
  1983. X
  1984. Xlintflags = -hbvxac
  1985. X
  1986. Xaddedbyconf = Makefile.old bsd eunice filexp loc pdp11 usg v7
  1987. X
  1988. X# grrr
  1989. XSHELL = /bin/sh
  1990. X
  1991. X.c.o:
  1992. X    $(CC) -c $(CFLAGS) $*.c
  1993. X
  1994. Xall: $(public) $(private) $(util) uperl.o $(scripts)
  1995. X    cd x2p; $(MAKE) all
  1996. X    touch all
  1997. X
  1998. X# This is the standard version that contains no "taint" checks and is
  1999. X# used for all scripts that aren't set-id or running under something set-id.
  2000. X# The $& notation is tells Sequent machines that it can do a parallel make,
  2001. X# and is harmless otherwise.
  2002. X
  2003. Xperl: $& perly.o $(obj) usersub.o
  2004. X    $(CC) $(LARGE) $(CLDFLAGS) $(obj) perly.o usersub.o $(libs) -o perl
  2005. X
  2006. Xuperl.o: $& perly.o $(obj)
  2007. X    -ld $(LARGE) $(LDFLAGS) -r $(obj) perly.o $(libs) -o uperl.o
  2008. X
  2009. Xsaber: perly.c
  2010. X    # load $(c) perly.c
  2011. X
  2012. X# This version, if specified in Configure, does ONLY those scripts which need
  2013. X# set-id emulation.  Suidperl must be setuid root.  It contains the "taint"
  2014. X# checks as well as the special code to validate that the script in question
  2015. X# has been invoked correctly.
  2016. X
  2017. Xsuidperl: $& tperly.o sperl.o $(tobj) usersub.o
  2018. X    $(CC) $(LARGE) $(CLDFLAGS) sperl.o $(tobj) tperly.o usersub.o $(libs) \
  2019. X        -o suidperl
  2020. X
  2021. X# This version interprets scripts that are already set-id either via a wrapper
  2022. X# or through the kernel allowing set-id scripts (bad idea).  Taintperl must
  2023. X# NOT be setuid to root or anything else.  The only difference between it
  2024. X# and normal perl is the presence of the "taint" checks.
  2025. X
  2026. Xtaintperl: $& tperly.o tperl.o $(tobj) usersub.o
  2027. X    $(CC) $(LARGE) $(CLDFLAGS) tperl.o $(tobj) tperly.o usersub.o $(libs) \
  2028. X        -o taintperl
  2029. X
  2030. X# Replicating all this junk is yucky, but I don't see a portable way to fix it.
  2031. X
  2032. Xtperly.o: perly.c perly.h $(h)
  2033. X    /bin/rm -f tperly.c
  2034. X    $(SLN) perly.c tperly.c
  2035. X    $(CC) -c -DTAINT $(CFLAGS) tperly.c
  2036. X    /bin/rm -f tperly.c
  2037. X
  2038. Xtperl.o: perl.c perly.h patchlevel.h perl.h $(h)
  2039. X    /bin/rm -f tperl.c
  2040. X    $(SLN) perl.c tperl.c
  2041. X    $(CC) -c -DTAINT $(CFLAGS) tperl.c
  2042. X    /bin/rm -f tperl.c
  2043. X
  2044. Xsperl.o: perl.c perly.h patchlevel.h $(h)
  2045. X    /bin/rm -f sperl.c
  2046. X    $(SLN) perl.c sperl.c
  2047. X    $(CC) -c -DTAINT -DIAMSUID $(CFLAGS) sperl.c
  2048. X    /bin/rm -f sperl.c
  2049. X
  2050. Xtarray.o: array.c $(h)
  2051. X    /bin/rm -f tarray.c
  2052. X    $(SLN) array.c tarray.c
  2053. X    $(CC) -c -DTAINT $(CFLAGS) tarray.c
  2054. X    /bin/rm -f tarray.c
  2055. X
  2056. Xtcmd.o: cmd.c $(h)
  2057. X    /bin/rm -f tcmd.c
  2058. X    $(SLN) cmd.c tcmd.c
  2059. X    $(CC) -c -DTAINT $(CFLAGS) tcmd.c
  2060. X    /bin/rm -f tcmd.c
  2061. X
  2062. Xtcons.o: cons.c $(h) perly.h
  2063. X    /bin/rm -f tcons.c
  2064. X    $(SLN) cons.c tcons.c
  2065. X    $(CC) -c -DTAINT $(CFLAGS) tcons.c
  2066. X    /bin/rm -f tcons.c
  2067. X
  2068. Xtconsarg.o: consarg.c $(h)
  2069. X    /bin/rm -f tconsarg.c
  2070. X    $(SLN) consarg.c tconsarg.c
  2071. X    $(CC) -c -DTAINT $(CFLAGS) tconsarg.c
  2072. X    /bin/rm -f tconsarg.c
  2073. X
  2074. Xtdoarg.o: doarg.c $(h)
  2075. X    /bin/rm -f tdoarg.c
  2076. X    $(SLN) doarg.c tdoarg.c
  2077. X    $(CC) -c -DTAINT $(CFLAGS) tdoarg.c
  2078. X    /bin/rm -f tdoarg.c
  2079. X
  2080. Xtdoio.o: doio.c $(h)
  2081. X    /bin/rm -f tdoio.c
  2082. X    $(SLN) doio.c tdoio.c
  2083. X    $(CC) -c -DTAINT $(CFLAGS) tdoio.c
  2084. X    /bin/rm -f tdoio.c
  2085. X
  2086. Xtdolist.o: dolist.c $(h)
  2087. X    /bin/rm -f tdolist.c
  2088. X    $(SLN) dolist.c tdolist.c
  2089. X    $(CC) -c -DTAINT $(CFLAGS) tdolist.c
  2090. X    /bin/rm -f tdolist.c
  2091. X
  2092. Xtdump.o: dump.c $(h)
  2093. X    /bin/rm -f tdump.c
  2094. X    $(SLN) dump.c tdump.c
  2095. X    $(CC) -c -DTAINT $(CFLAGS) tdump.c
  2096. X    /bin/rm -f tdump.c
  2097. X
  2098. Xteval.o: eval.c $(h)
  2099. X    /bin/rm -f teval.c
  2100. X    $(SLN) eval.c teval.c
  2101. X    $(CC) -c -DTAINT $(CFLAGS) teval.c
  2102. X    /bin/rm -f teval.c
  2103. X
  2104. Xtform.o: form.c $(h)
  2105. X    /bin/rm -f tform.c
  2106. X    $(SLN) form.c tform.c
  2107. X    $(CC) -c -DTAINT $(CFLAGS) tform.c
  2108. X    /bin/rm -f tform.c
  2109. X
  2110. Xthash.o: hash.c $(h)
  2111. X    /bin/rm -f thash.c
  2112. X    $(SLN) hash.c thash.c
  2113. X    $(CC) -c -DTAINT $(CFLAGS) thash.c
  2114. X    /bin/rm -f thash.c
  2115. X
  2116. Xtregcomp.o: regcomp.c $(h)
  2117. X    /bin/rm -f tregcomp.c
  2118. X    $(SLN) regcomp.c tregcomp.c
  2119. X    $(CC) -c -DTAINT $(CFLAGS) tregcomp.c
  2120. X    /bin/rm -f tregcomp.c
  2121. X
  2122. Xtregexec.o: regexec.c $(h)
  2123. X    /bin/rm -f tregexec.c
  2124. X    $(SLN) regexec.c tregexec.c
  2125. X    $(CC) -c -DTAINT $(CFLAGS) tregexec.c
  2126. X    /bin/rm -f tregexec.c
  2127. X
  2128. Xtstab.o: stab.c $(h)
  2129. X    /bin/rm -f tstab.c
  2130. X    $(SLN) stab.c tstab.c
  2131. X    $(CC) -c -DTAINT $(CFLAGS) tstab.c
  2132. X    /bin/rm -f tstab.c
  2133. X
  2134. Xtstr.o: str.c $(h) perly.h
  2135. X    /bin/rm -f tstr.c
  2136. X    $(SLN) str.c tstr.c
  2137. X    $(CC) -c -DTAINT $(CFLAGS) tstr.c
  2138. X    /bin/rm -f tstr.c
  2139. X
  2140. Xttoke.o: toke.c $(h) perly.h
  2141. X    /bin/rm -f ttoke.c
  2142. X    $(SLN) toke.c ttoke.c
  2143. X    $(CC) -c -DTAINT $(CFLAGS) ttoke.c
  2144. X    /bin/rm -f ttoke.c
  2145. X
  2146. Xtutil.o: util.c $(h)
  2147. X    /bin/rm -f tutil.c
  2148. X    $(SLN) util.c tutil.c
  2149. X    $(CC) -c -DTAINT $(CFLAGS) tutil.c
  2150. X    /bin/rm -f tutil.c
  2151. X
  2152. Xperly.h: perly.c
  2153. X    @ echo Dummy dependency for dumb parallel make
  2154. X    touch perly.h
  2155. X
  2156. Xperly.c: perly.y
  2157. X    @ echo 'Expect either' 29 shift/reduce and 59 reduce/reduce conflicts...
  2158. X    @ echo '           or' 27 shift/reduce and 61 reduce/reduce conflicts...
  2159. X    $(YACC) -d perly.y
  2160. X    sh perly.fixer y.tab.c perly.c
  2161. X    mv y.tab.h perly.h
  2162. X    echo 'extern YYSTYPE yylval;' >>perly.h
  2163. X
  2164. Xperly.o: perly.c perly.h $(h)
  2165. X    $(CC) -c $(CFLAGS) perly.c
  2166. X
  2167. Xinstall: all
  2168. X    ./perl installperl
  2169. X    cd x2p; $(MAKE) install
  2170. X
  2171. Xclean:
  2172. X    rm -f *.o all perl taintperl suidperl
  2173. X    cd x2p; $(MAKE) clean
  2174. X
  2175. Xrealclean: clean
  2176. X    cd x2p; $(MAKE) realclean
  2177. X    rm -f *.orig */*.orig *~ */*~ core $(addedbyconf) h2ph h2ph.man
  2178. X    rm -f perly.c perly.h t/perl Makefile config.h makedepend makedir
  2179. X    rm -f x2p/Makefile
  2180. X
  2181. X# The following lint has practically everything turned on.  Unfortunately,
  2182. X# you have to wade through a lot of mumbo jumbo that can't be suppressed.
  2183. X# If the source file has a /*NOSTRICT*/ somewhere, ignore the lint message
  2184. X# for that spot.
  2185. X
  2186. Xlint: perly.c $(c)
  2187. X    lint $(lintflags) $(defs) perly.c $(c) > perl.fuzz
  2188. X
  2189. Xdepend: makedepend
  2190. X    - test -f perly.h || cp /dev/null perly.h
  2191. X    ./makedepend
  2192. X    - test -s perly.h || /bin/rm -f perly.h
  2193. X    cd x2p; $(MAKE) depend
  2194. X
  2195. Xtest: perl
  2196. X    - cd t && chmod +x TEST */*.t
  2197. X    - cd t && (rm -f perl; $(SLN) ../perl .) && ./perl TEST </dev/tty
  2198. X
  2199. Xclist:
  2200. X    echo $(c) | tr ' ' '\012' >.clist
  2201. X
  2202. Xhlist:
  2203. X    echo $(h) | tr ' ' '\012' >.hlist
  2204. X
  2205. Xshlist:
  2206. X    echo $(sh) | tr ' ' '\012' >.shlist
  2207. X
  2208. X# AUTOMATICALLY GENERATED MAKE DEPENDENCIES--PUT NOTHING BELOW THIS LINE
  2209. X$(obj):
  2210. X    @ echo "You haven't done a "'"make depend" yet!'; exit 1
  2211. Xmakedepend: makedepend.SH
  2212. X    /bin/sh makedepend.SH
  2213. X!NO!SUBS!
  2214. X$eunicefix Makefile
  2215. Xcase `pwd` in
  2216. X*SH)
  2217. X    $rm -f ../Makefile
  2218. X    ln Makefile ../Makefile
  2219. X    ;;
  2220. Xesac
  2221. !STUFFY!FUNK!
  2222. echo Extracting lib/cacheout.pl
  2223. sed >lib/cacheout.pl <<'!STUFFY!FUNK!' -e 's/X//'
  2224. X#!/usr/bin/perl
  2225. X
  2226. X# Open in their package.
  2227. X
  2228. Xsub cacheout'open {
  2229. X    open($_[0], $_[1]);
  2230. X}
  2231. X
  2232. X# But only this sub name is visible to them.
  2233. X
  2234. Xsub cacheout {
  2235. X    package cacheout;
  2236. X
  2237. X    ($file) = @_;
  2238. X    ($package) = caller;
  2239. X    if (!$isopen{$file}) {
  2240. X    if (++$numopen > $maxopen) {
  2241. X        sub byseq {$isopen{$a} != $isopen{$b};}
  2242. X        local(@lru) = sort byseq keys(%isopen);
  2243. X        splice(@lru, $maxopen / 3);
  2244. X        $numopen -= @lru;
  2245. X        for (@lru) { close $_; delete $isopen{$_}; }
  2246. X    }
  2247. X    &open($file, ($saw{$file}++ ? '>>' : '>') . $file)
  2248. X        || die "Can't create $file: $!\n";
  2249. X    }
  2250. X    $isopen{$file} = ++$seq;
  2251. X}
  2252. X
  2253. Xpackage cacheout;
  2254. X
  2255. X$seq = 0;
  2256. X$numopen = 0;
  2257. X
  2258. Xif (open(PARAM,'/usr/include/sys/param.h')) {
  2259. X    local($.);
  2260. X    while (<PARAM>) {
  2261. X    $maxopen = $1 - 4 if /^#define NOFILE\s+(\d+)/;
  2262. X    }
  2263. X    close PARAM;
  2264. X}
  2265. X$maxopen = 16 unless $maxopen;
  2266. X
  2267. X1;
  2268. !STUFFY!FUNK!
  2269. echo " "
  2270. echo "End of kit 28 (of 36)"
  2271. cat /dev/null >kit28isdone
  2272. run=''
  2273. config=''
  2274. 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
  2275.     if test -f kit${iskit}isdone; then
  2276.     run="$run $iskit"
  2277.     else
  2278.     todo="$todo $iskit"
  2279.     fi
  2280. done
  2281. case $todo in
  2282.     '')
  2283.     echo "You have run all your kits.  Please read README and then type Configure."
  2284.     for combo in *:AA; do
  2285.         if test -f "$combo"; then
  2286.         realfile=`basename $combo :AA`
  2287.         cat $realfile:[A-Z][A-Z] >$realfile
  2288.         rm -rf $realfile:[A-Z][A-Z]
  2289.         fi
  2290.     done
  2291.     rm -rf kit*isdone
  2292.     chmod 755 Configure
  2293.     ;;
  2294.     *)  echo "You have run$run."
  2295.     echo "You still need to run$todo."
  2296.     ;;
  2297. esac
  2298. : Someone might mail this, so...
  2299. exit
  2300.  
  2301. exit 0 # Just in case...
  2302. -- 
  2303. Kent Landfield                   INTERNET: kent@sparky.IMD.Sterling.COM
  2304. Sterling Software, IMD           UUCP:     uunet!sparky!kent
  2305. Phone:    (402) 291-8300         FAX:      (402) 291-4362
  2306. Please send comp.sources.misc-related mail to kent@uunet.uu.net.
  2307.