home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1994 October / usenetsourcesnewsgroupsinfomagicoctober1994disk2.iso / unix / volume20 / perl3.0 / part23 < prev    next >
Encoding:
Internet Message Format  |  1989-11-01  |  49.0 KB
  1. Subject:  v20i106:  Perl, a language with features of C/sed/awk/shell/etc, Part23/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 106
  8. Archive-name: perl3.0/part23
  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 23 (of 24).  If kit 23 is complete, the line"
  16. echo '"'"End of kit 23 (of 24)"'" will echo at the end.'
  17. echo ""
  18. export PATH || (echo "You didn't use sh, you clunch." ; kill $$)
  19. mkdir eg eg/g eg/scan eg/van lib t x2p 2>/dev/null
  20. echo Extracting eg/scan/scanner
  21. sed >eg/scan/scanner <<'!STUFFY!FUNK!' -e 's/X//'
  22. X#!/usr/bin/perl
  23. X
  24. X# $Header: scanner,v 3.0 89/10/18 15:16:02 lwall Locked $
  25. X
  26. X# This runs all the scan_* routines on all the machines in /etc/ghosts.
  27. X# We run this every morning at about 6 am:
  28. X
  29. X#    !/bin/sh
  30. X#    cd /usr/adm/private
  31. X#    decrypt scanner | perl >scan.out 2>&1
  32. X#    mail admin <scan.out
  33. X
  34. X# Note that the scan_* files should be encrypted with the key "-inquire", and
  35. X# scanner should be encrypted somehow so that people can't find that key.
  36. X# I leave it up to you to figure out how to unencrypt it before executing.
  37. X
  38. X$ENV{'PATH'} = '/bin:/usr/bin:/usr/local/bin:/usr/ucb:.';
  39. X
  40. X$| = 1;        # command buffering on stdout
  41. X
  42. Xprint "Subject: bizarre happenings\n\n";
  43. X
  44. X(chdir '/usr/adm/private') || die "Can't cd to /usr/adm/private: $!\n";
  45. X
  46. Xif ($#ARGV >= 0) {
  47. X    @scanlist = @ARGV;
  48. X} else {
  49. X    @scanlist = split(/[ \t\n]+/,`echo scan_*`);
  50. X}
  51. X
  52. Xscan: while ($scan = shift(@scanlist)) {
  53. X    print "\n********** $scan **********\n";
  54. X    $showhost++;
  55. X
  56. X    $systype = 'all';
  57. X
  58. X    open(ghosts, '/etc/ghosts') || die 'No /etc/ghosts file';
  59. X
  60. X    $one_of_these = ":$systype:";
  61. X    if ($systype =~ s/\+/[+]/g) {
  62. X    $one_of_these =~ s/\+/:/g;
  63. X    }
  64. X
  65. X    line: while (<ghosts>) {
  66. X    s/[ \t]*\n//;
  67. X    if (!$_ || /^#/) {
  68. X        next line;
  69. X    }
  70. X    if (/^([a-zA-Z_0-9]+)=(.+)/) {
  71. X        $name = $1; $repl = $2;
  72. X        $repl =~ s/\+/:/g;
  73. X        $one_of_these =~ s/:$name:/:$repl:/;
  74. X        next line;
  75. X    }
  76. X    @gh = split;
  77. X    $host = $gh[0];
  78. X    if ($showhost) { $showhost = "$host:\t"; }
  79. X    class: while ($class = pop(gh)) {
  80. X        if (index($one_of_these,":$class:") >=0) {
  81. X        $iter = 0;
  82. X        `exec crypt -inquire <$scan >.x 2>/dev/null`;
  83. X        unless (open(scan,'.x')) {
  84. X            print "Can't run $scan: $!\n";
  85. X            next scan;
  86. X        }
  87. X        $cmd = <scan>;
  88. X        unless ($cmd =~ s/#!(.*)\n/$1/) {
  89. X            $cmd = '/usr/bin/perl';
  90. X        }
  91. X        close(scan);
  92. X        if (open(pipe,"exec rsh $host '$cmd' <.x|")) {
  93. X            sleep(5);
  94. X            unlink '.x';
  95. X            while (<pipe>) {
  96. X            last if $iter++ > 1000;        # must be looping
  97. X            next if /^[0-9.]+u [0-9.]+s/;
  98. X            print $showhost,$_;
  99. X            }
  100. X            close(pipe);
  101. X        } else {
  102. X            print "(Can't execute rsh: $!)\n";
  103. X        }
  104. X        last class;
  105. X        }
  106. X    }
  107. X    }
  108. X}
  109. !STUFFY!FUNK!
  110. echo Extracting eg/g/gcp.man
  111. sed >eg/g/gcp.man <<'!STUFFY!FUNK!' -e 's/X//'
  112. X.\" $Header: gcp.man,v 3.0 89/10/18 15:14:09 lwall Locked $
  113. X.TH GCP 1C "13 May 1988"
  114. X.SH NAME
  115. Xgcp \- global file copy
  116. X.SH SYNOPSIS
  117. X.B gcp
  118. Xfile1 file2
  119. X.br
  120. X.B gcp
  121. X[
  122. X.B \-r
  123. X] file ... directory
  124. X.SH DESCRIPTION
  125. X.I gcp
  126. Xworks just like rcp(1C) except that you may specify a set of hosts to copy files
  127. Xfrom or to.
  128. XThe host sets are defined in the file /etc/ghosts.
  129. X(An individual host name can be used as a set containing one member.)
  130. XYou can give a command like
  131. X
  132. X    gcp /etc/motd sun:
  133. X
  134. Xto copy your /etc/motd file to /etc/motd on all the Suns.
  135. XIf, on the other hand, you say
  136. X
  137. X    gcp /a/foo /b/bar sun:/tmp
  138. X
  139. Xthen your files will be copied to /tmp on all the Suns.
  140. XThe general rule is that if you don't specify the destination directory,
  141. Xfiles go to the same directory they are in currently.
  142. X.P
  143. XYou may specify the union of two or more sets by using + as follows:
  144. X
  145. X    gcp /a/foo /b/bar 750+mc:
  146. X
  147. Xwhich will copy /a/foo to /a/foo on all 750's and Masscomps, and then copy
  148. X/b/bar to /b/bar on all 750's and Masscomps.
  149. X.P
  150. XCommonly used sets should be defined in /etc/ghosts.
  151. XFor example, you could add a line that says
  152. X
  153. X    pep=manny+moe+jack
  154. X
  155. XAnother way to do that would be to add the word "pep" after each of the host
  156. Xentries:
  157. X
  158. X    manny    sun3 pep
  159. X.br
  160. X    moe        sun3 pep
  161. X.br
  162. X    jack        sun3 pep
  163. X
  164. XHosts and sets of host can also be excluded:
  165. X
  166. X    foo=sun-sun2
  167. X
  168. XAny host so excluded will never be included, even if a subsequent set on the
  169. Xline includes it:
  170. X
  171. X    foo=abc+def
  172. X.br
  173. X    bar=xyz-abc+foo
  174. X
  175. Xcomes out to xyz+def.
  176. X
  177. XYou can define private host sets by creating .ghosts in your current directory
  178. Xwith entries just like /etc/ghosts.
  179. XAlso, if there is a file .grem, it defines "rem" to be the remaining hosts
  180. Xfrom the last gsh or gcp that didn't succeed everywhere.
  181. X.PP
  182. XInterrupting with a SIGINT will cause the rcp to the current host to be skipped
  183. Xand execution resumed with the next host.
  184. XTo stop completely, send a SIGQUIT.
  185. X.SH SEE ALSO
  186. Xrcp(1C)
  187. X.SH BUGS
  188. XAll the bugs of rcp, since it calls rcp.
  189. !STUFFY!FUNK!
  190. echo Extracting lib/complete.pl
  191. sed >lib/complete.pl <<'!STUFFY!FUNK!' -e 's/X//'
  192. X;#
  193. X;#    @(#)complete.pl    1.0 (sun!waynet) 11/11/88
  194. X;#
  195. X;# Author: Wayne Thompson
  196. X;#
  197. X;# Description:
  198. X;#     This routine provides word completion.
  199. X;#     (TAB) attempts word completion.
  200. X;#     (^D)  prints completion list.
  201. X;#
  202. X;# Diagnostics:
  203. X;#     Bell when word completion fails.
  204. X;#
  205. X;# Dependencies:
  206. X;#     The tty driver is put into raw mode.
  207. X;#
  208. X;# Bugs:
  209. X;#     The erase and kill characters are hard coded.
  210. X;#
  211. X;# Usage:
  212. X;#     $input = do Complete('prompt_string', @completion_list);
  213. X;#
  214. X
  215. Xsub Complete {
  216. X    local ($prompt) = shift (@_);
  217. X    local ($c, $cmp, $l, $r, $ret, $return, $test);
  218. X    @_ = sort @_;
  219. X    system 'stty raw -echo';
  220. X    loop: {
  221. X    print $prompt, $return;
  222. X    while (($c = getc(stdin)) ne "\r") {
  223. X        if ($c eq "\t") {            # (TAB) attempt completion
  224. X        @_match = ();
  225. X        foreach $cmp (@_) {
  226. X            push (@_match, $cmp) if $cmp =~ /^$return/;
  227. X        }
  228. X                $test = $_match[0];
  229. X                $l = length ($test);
  230. X        unless ($#_match == 0) {
  231. X                    shift (@_match);
  232. X                    foreach $cmp (@_match) {
  233. X                        until (substr ($cmp, 0, $l) eq substr ($test, 0, $l)) {
  234. X                            $l--;
  235. X                        }
  236. X                    }
  237. X                    print "\007";
  238. X                }
  239. X                print $test = substr ($test, $r, $l - $r);
  240. X                $r = length ($return .= $test);
  241. X        }
  242. X        elsif ($c eq "\004") {        # (^D) completion list
  243. X        print "\r\n";
  244. X        foreach $cmp (@_) {
  245. X            print "$cmp\r\n" if $cmp =~ /^$return/;
  246. X        }
  247. X        redo loop;
  248. X        }
  249. X            elsif ($c eq "\025" && $r) {    # (^U) kill
  250. X                $return = '';
  251. X                $r = 0;
  252. X                print "\r\n";
  253. X                redo loop;
  254. X            }
  255. X                                            # (DEL) || (BS) erase
  256. X        elsif ($c eq "\177" || $c eq "\010") {
  257. X        if($r) {
  258. X            print "\b \b";
  259. X            chop ($return);
  260. X            $r--;
  261. X        }
  262. X        }
  263. X        elsif ($c =~ /\S/) {                # printable char
  264. X        $return .= $c;
  265. X        $r++;
  266. X        print $c;
  267. X        }
  268. X    }
  269. X    }
  270. X    system 'stty -raw echo';
  271. X    print "\n";
  272. X    $return;
  273. X}
  274. X
  275. X1;
  276. !STUFFY!FUNK!
  277. echo Extracting t/op.study
  278. sed >t/op.study <<'!STUFFY!FUNK!' -e 's/X//'
  279. X#!./perl
  280. X
  281. X# $Header: op.study,v 3.0 89/10/18 15:31:38 lwall Locked $
  282. X
  283. Xprint "1..24\n";
  284. X
  285. X$x = "abc\ndef\n";
  286. Xstudy($x);
  287. X
  288. Xif ($x =~ /^abc/) {print "ok 1\n";} else {print "not ok 1\n";}
  289. Xif ($x !~ /^def/) {print "ok 2\n";} else {print "not ok 2\n";}
  290. X
  291. X$* = 1;
  292. Xif ($x =~ /^def/) {print "ok 3\n";} else {print "not ok 3\n";}
  293. X$* = 0;
  294. X
  295. X$_ = '123';
  296. Xstudy;
  297. Xif (/^([0-9][0-9]*)/) {print "ok 4\n";} else {print "not ok 4\n";}
  298. X
  299. Xif ($x =~ /^xxx/) {print "not ok 5\n";} else {print "ok 5\n";}
  300. Xif ($x !~ /^abc/) {print "not ok 6\n";} else {print "ok 6\n";}
  301. X
  302. Xif ($x =~ /def/) {print "ok 7\n";} else {print "not ok 7\n";}
  303. Xif ($x !~ /def/) {print "not ok 8\n";} else {print "ok 8\n";}
  304. X
  305. Xstudy($x);
  306. Xif ($x !~ /.def/) {print "ok 9\n";} else {print "not ok 9\n";}
  307. Xif ($x =~ /.def/) {print "not ok 10\n";} else {print "ok 10\n";}
  308. X
  309. Xif ($x =~ /\ndef/) {print "ok 11\n";} else {print "not ok 11\n";}
  310. Xif ($x !~ /\ndef/) {print "not ok 12\n";} else {print "ok 12\n";}
  311. X
  312. X$_ = 'aaabbbccc';
  313. Xstudy;
  314. Xif (/(a*b*)(c*)/ && $1 eq 'aaabbb' && $2 eq 'ccc') {
  315. X    print "ok 13\n";
  316. X} else {
  317. X    print "not ok 13\n";
  318. X}
  319. Xif (/(a+b+c+)/ && $1 eq 'aaabbbccc') {
  320. X    print "ok 14\n";
  321. X} else {
  322. X    print "not ok 14\n";
  323. X}
  324. X
  325. Xif (/a+b?c+/) {print "not ok 15\n";} else {print "ok 15\n";}
  326. X
  327. X$_ = 'aaabccc';
  328. Xstudy;
  329. Xif (/a+b?c+/) {print "ok 16\n";} else {print "not ok 16\n";}
  330. Xif (/a*b+c*/) {print "ok 17\n";} else {print "not ok 17\n";}
  331. X
  332. X$_ = 'aaaccc';
  333. Xstudy;
  334. Xif (/a*b?c*/) {print "ok 18\n";} else {print "not ok 18\n";}
  335. Xif (/a*b+c*/) {print "not ok 19\n";} else {print "ok 19\n";}
  336. X
  337. X$_ = 'abcdef';
  338. Xstudy;
  339. Xif (/bcd|xyz/) {print "ok 20\n";} else {print "not ok 20\n";}
  340. Xif (/xyz|bcd/) {print "ok 21\n";} else {print "not ok 21\n";}
  341. X
  342. Xif (m|bc/*d|) {print "ok 22\n";} else {print "not ok 22\n";}
  343. X
  344. Xif (/^$_$/) {print "ok 23\n";} else {print "not ok 23\n";}
  345. X
  346. X$* = 1;        # test 3 only tested the optimized version--this one is for real
  347. Xif ("ab\ncd\n" =~ /^cd/) {print "ok 24\n";} else {print "not ok 24\n";}
  348. !STUFFY!FUNK!
  349. echo Extracting hash.h
  350. sed >hash.h <<'!STUFFY!FUNK!' -e 's/X//'
  351. X/* $Header: hash.h,v 3.0 89/10/18 15:18:39 lwall Locked $
  352. X *
  353. X *    Copyright (c) 1989, Larry Wall
  354. X *
  355. X *    You may distribute under the terms of the GNU General Public License
  356. X *    as specified in the README file that comes with the perl 3.0 kit.
  357. X *
  358. X * $Log:    hash.h,v $
  359. X * Revision 3.0  89/10/18  15:18:39  lwall
  360. X * 3.0 baseline
  361. X * 
  362. X */
  363. X
  364. X#define FILLPCT 80        /* don't make greater than 99 */
  365. X#define DBM_CACHE_MAX 63    /* cache 64 entries for dbm file */
  366. X                /* (resident array acts as a write-thru cache)*/
  367. X
  368. X#define COEFFSIZE (16 * 8)    /* size of array below */
  369. X#ifdef DOINIT
  370. Xchar coeff[] = {
  371. X        61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1,
  372. X        61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1,
  373. X        61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1,
  374. X        61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1,
  375. X        61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1,
  376. X        61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1,
  377. X        61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1,
  378. X        61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1};
  379. X#else
  380. Xextern char coeff[];
  381. X#endif
  382. X
  383. Xtypedef struct hentry HENT;
  384. X
  385. Xstruct hentry {
  386. X    HENT    *hent_next;
  387. X    char    *hent_key;
  388. X    STR        *hent_val;
  389. X    int        hent_hash;
  390. X    int        hent_klen;
  391. X};
  392. X
  393. Xstruct htbl {
  394. X    HENT    **tbl_array;
  395. X    int        tbl_max;    /* subscript of last element of tbl_array */
  396. X    int        tbl_dosplit;    /* how full to get before splitting */
  397. X    int        tbl_fill;    /* how full tbl_array currently is */
  398. X    int        tbl_riter;    /* current root of iterator */
  399. X    HENT    *tbl_eiter;    /* current entry of iterator */
  400. X    SPAT     *tbl_spatroot;    /* list of spats for this package */
  401. X#ifdef SOME_DBM
  402. X#ifdef NDBM
  403. X    DBM        *tbl_dbm;
  404. X#else
  405. X    int        tbl_dbm;
  406. X#endif
  407. X#endif
  408. X    unsigned char tbl_coeffsize;    /* is 0 for symbol tables */
  409. X};
  410. X
  411. XSTR *hfetch();
  412. Xbool hstore();
  413. XSTR *hdelete();
  414. XHASH *hnew();
  415. Xvoid hclear();
  416. Xvoid hentfree();
  417. Xint hiterinit();
  418. XHENT *hiternext();
  419. Xchar *hiterkey();
  420. XSTR *hiterval();
  421. Xbool hdbmopen();
  422. Xvoid hdbmclose();
  423. Xbool hdbmstore();
  424. !STUFFY!FUNK!
  425. echo Extracting t/TEST
  426. sed >t/TEST <<'!STUFFY!FUNK!' -e 's/X//'
  427. X#!./perl
  428. X
  429. X# $Header: TEST,v 3.0 89/10/18 15:24:06 lwall Locked $
  430. X
  431. X# This is written in a peculiar style, since we're trying to avoid
  432. X# most of the constructs we'll be testing for.
  433. X
  434. X$| = 1;
  435. X
  436. Xif ($ARGV[0] eq '-v') {
  437. X    $verbose = 1;
  438. X    shift;
  439. X}
  440. X
  441. Xchdir 't' if -f 't/TEST';
  442. X
  443. Xif ($ARGV[0] eq '') {
  444. X    @ARGV = split(/[ \n]/,`echo base.* comp.* cmd.* io.* op.*`);
  445. X}
  446. X
  447. Xopen(config,"../config.sh");
  448. Xwhile (<config>) {
  449. X    if (/sharpbang='(.*)'/) {
  450. X    $sharpbang = ($1 eq '#!');
  451. X    last;
  452. X    }
  453. X}
  454. X$bad = 0;
  455. Xwhile ($test = shift) {
  456. X    if ($test =~ /\.orig$/) {
  457. X    next;
  458. X    }
  459. X    if ($test =~ /~$/) {
  460. X    next;
  461. X    }
  462. X    print "$test" . '.' x (16 - length($test));
  463. X    if ($sharpbang) {
  464. X    open(results,"./$test|") || (print "can't run.\n");
  465. X    } else {
  466. X    open(script,"$test") || die "Can't run $test.\n";
  467. X    $_ = <script>;
  468. X    close(script);
  469. X    if (/#!..perl(.*)/) {
  470. X        $switch = $1;
  471. X    } else {
  472. X        $switch = '';
  473. X    }
  474. X    open(results,"./perl$switch $test|") || (print "can't run.\n");
  475. X    }
  476. X    $ok = 0;
  477. X    $next = 0;
  478. X    while (<results>) {
  479. X    if ($verbose) {
  480. X        print $_;
  481. X    }
  482. X    unless (/^#/) {
  483. X        if (/^1\.\.([0-9]+)/) {
  484. X        $max = $1;
  485. X        $next = 1;
  486. X        $ok = 1;
  487. X        } else {
  488. X        if (/^ok (.*)/ && $1 == $next) {
  489. X            $next = $next + 1;
  490. X        } else {
  491. X            $ok = 0;
  492. X        }
  493. X        }
  494. X    }
  495. X    }
  496. X    $next = $next - 1;
  497. X    if ($ok && $next == $max) {
  498. X    print "ok\n";
  499. X    } else {
  500. X    $next += 1;
  501. X    print "FAILED on test $next\n";
  502. X    $bad = $bad + 1;
  503. X    $_ = $test;
  504. X    if (/^base/) {
  505. X        die "Failed a basic test--cannot continue.\n";
  506. X    }
  507. X    }
  508. X}
  509. X
  510. Xif ($bad == 0) {
  511. X    if ($ok) {
  512. X    print "All tests successful.\n";
  513. X    } else {
  514. X    die "FAILED--no tests were run for some reason.\n";
  515. X    }
  516. X} else {
  517. X    if ($bad == 1) {
  518. X    die "Failed 1 test.\n";
  519. X    } else {
  520. X    die "Failed $bad tests.\n";
  521. X    }
  522. X}
  523. X($user,$sys,$cuser,$csys) = times;
  524. Xprint sprintf("u=%g  s=%g  cu=%g  cs=%g\n",$user,$sys,$cuser,$csys);
  525. !STUFFY!FUNK!
  526. echo Extracting t/op.write
  527. sed >t/op.write <<'!STUFFY!FUNK!' -e 's/X//'
  528. X#!./perl
  529. X
  530. X# $Header: op.write,v 3.0 89/10/18 15:32:16 lwall Locked $
  531. X
  532. Xprint "1..2\n";
  533. X
  534. Xformat OUT =
  535. Xthe quick brown @<<
  536. X$fox
  537. Xjumped
  538. X@*
  539. X$multiline
  540. X^<<<<<<<<<
  541. X$foo
  542. X^<<<<<<<<<
  543. X$foo
  544. X^<<<<<<...
  545. X$foo
  546. Xnow @<<the@>>>> for all@|||||men to come @<<<<
  547. X'i' . 's', "time\n", $good, 'to'
  548. X.
  549. X
  550. Xopen(OUT, '>Op.write.tmp') || die "Can't create Op.write.tmp";
  551. X
  552. X$fox = 'foxiness';
  553. X$good = 'good';
  554. X$multiline = "forescore\nand\nseven years\n";
  555. X$foo = 'when in the course of human events it becomes necessary';
  556. Xwrite(OUT);
  557. Xclose OUT;
  558. X
  559. X$right =
  560. X"the quick brown fox
  561. Xjumped
  562. Xforescore
  563. Xand
  564. Xseven years
  565. Xwhen in
  566. Xthe course
  567. Xof huma...
  568. Xnow is the time for all good men to come to\n";
  569. X
  570. Xif (`cat Op.write.tmp` eq $right)
  571. X    { print "ok 1\n"; unlink 'Op.write.tmp'; }
  572. Xelse
  573. X    { print "not ok 1\n"; }
  574. X
  575. Xformat OUT2 =
  576. Xthe quick brown @<<
  577. X$fox
  578. Xjumped
  579. X@*
  580. X$multiline
  581. X^<<<<<<<<< ~~
  582. X$foo
  583. Xnow @<<the@>>>> for all@|||||men to come @<<<<
  584. X'i' . 's', "time\n", $good, 'to'
  585. X.
  586. X
  587. Xopen(OUT2, '>Op.write.tmp') || die "Can't create Op.write.tmp";
  588. X
  589. X$fox = 'foxiness';
  590. X$good = 'good';
  591. X$multiline = "forescore\nand\nseven years\n";
  592. X$foo = 'when in the course of human events it becomes necessary';
  593. Xwrite(OUT2);
  594. Xclose OUT2;
  595. X
  596. X$right =
  597. X"the quick brown fox
  598. Xjumped
  599. Xforescore
  600. Xand
  601. Xseven years
  602. Xwhen in
  603. Xthe course
  604. Xof human
  605. Xevents it
  606. Xbecomes
  607. Xnecessary
  608. Xnow is the time for all good men to come to\n";
  609. X
  610. Xif (`cat Op.write.tmp` eq $right)
  611. X    { print "ok 2\n"; unlink 'Op.write.tmp'; }
  612. Xelse
  613. X    { print "not ok 2\n"; }
  614. X
  615. !STUFFY!FUNK!
  616. echo Extracting t/op.substr
  617. sed >t/op.substr <<'!STUFFY!FUNK!' -e 's/X//'
  618. X#!./perl
  619. X
  620. X# $Header: op.substr,v 3.0 89/10/18 15:31:52 lwall Locked $
  621. X
  622. Xprint "1..19\n";
  623. X
  624. X$a = 'abcdefxyz';
  625. X
  626. Xprint (substr($a,0,3) eq 'abc' ? "ok 1\n" : "not ok 1\n");
  627. Xprint (substr($a,3,3) eq 'def' ? "ok 2\n" : "not ok 2\n");
  628. Xprint (substr($a,6,999) eq 'xyz' ? "ok 3\n" : "not ok 3\n");
  629. Xprint (substr($a,999,999) eq '' ? "ok 4\n" : "not ok 4\n");
  630. Xprint (substr($a,6,-1) eq '' ? "ok 5\n" : "not ok 5\n");
  631. Xprint (substr($a,-3,1) eq 'x' ? "ok 6\n" : "not ok 6\n");
  632. X
  633. X$[ = 1;
  634. X
  635. Xprint (substr($a,1,3) eq 'abc' ? "ok 7\n" : "not ok 7\n");
  636. Xprint (substr($a,4,3) eq 'def' ? "ok 8\n" : "not ok 8\n");
  637. Xprint (substr($a,7,999) eq 'xyz' ? "ok 9\n" : "not ok 9\n");
  638. Xprint (substr($a,999,999) eq '' ? "ok 10\n" : "not ok 10\n");
  639. Xprint (substr($a,7,-1) eq '' ? "ok 11\n" : "not ok 11\n");
  640. Xprint (substr($a,-3,1) eq 'x' ? "ok 12\n" : "not ok 12\n");
  641. X
  642. X$[ = 0;
  643. X
  644. Xsubstr($a,3,3) = 'XYZ';
  645. Xprint $a eq 'abcXYZxyz' ? "ok 13\n" : "not ok 13\n";
  646. Xsubstr($a,0,2) = '';
  647. Xprint $a eq 'cXYZxyz' ? "ok 14\n" : "not ok 14\n";
  648. Xy/a/a/;
  649. Xsubstr($a,0,0) = 'ab';
  650. Xprint $a eq 'abcXYZxyz' ? "ok 15\n" : "not ok 15 $a\n";
  651. Xsubstr($a,0,0) = '12345678';
  652. Xprint $a eq '12345678abcXYZxyz' ? "ok 16\n" : "not ok 16\n";
  653. Xsubstr($a,-3,3) = 'def';
  654. Xprint $a eq '12345678abcXYZdef' ? "ok 17\n" : "not ok 17\n";
  655. Xsubstr($a,-3,3) = '<';
  656. Xprint $a eq '12345678abcXYZ<' ? "ok 18\n" : "not ok 18\n";
  657. Xsubstr($a,-1,1) = '12345678';
  658. Xprint $a eq '12345678abcXYZ12345678' ? "ok 19\n" : "not ok 19\n";
  659. X
  660. !STUFFY!FUNK!
  661. echo Extracting spat.h
  662. sed >spat.h <<'!STUFFY!FUNK!' -e 's/X//'
  663. X/* $Header: spat.h,v 3.0 89/10/18 15:23:14 lwall Locked $
  664. X *
  665. X *    Copyright (c) 1989, Larry Wall
  666. X *
  667. X *    You may distribute under the terms of the GNU General Public License
  668. X *    as specified in the README file that comes with the perl 3.0 kit.
  669. X *
  670. X * $Log:    spat.h,v $
  671. X * Revision 3.0  89/10/18  15:23:14  lwall
  672. X * 3.0 baseline
  673. X * 
  674. X */
  675. X
  676. Xstruct scanpat {
  677. X    SPAT    *spat_next;        /* list of all scanpats */
  678. X    REGEXP    *spat_regexp;        /* compiled expression */
  679. X    ARG        *spat_repl;        /* replacement string for subst */
  680. X    ARG        *spat_runtime;        /* compile pattern at runtime */
  681. X    STR        *spat_short;        /* for a fast bypass of execute() */
  682. X    bool    spat_flags;
  683. X    char    spat_slen;
  684. X};
  685. X
  686. X#define SPAT_USED 1            /* spat has been used once already */
  687. X#define SPAT_ONCE 2            /* use pattern only once per reset */
  688. X#define SPAT_SCANFIRST 4        /* initial constant not anchored */
  689. X#define SPAT_ALL 8            /* initial constant is whole pat */
  690. X#define SPAT_SKIPWHITE 16        /* skip leading whitespace for split */
  691. X#define SPAT_FOLD 32            /* case insensitivity */
  692. X#define SPAT_CONST 64            /* subst replacement is constant */
  693. X#define SPAT_KEEP 128            /* keep 1st runtime pattern forever */
  694. X
  695. XEXT SPAT *curspat;        /* what to do \ interps from */
  696. XEXT SPAT *lastspat;        /* what to use in place of null pattern */
  697. X
  698. XEXT char *hint INIT(Nullch);    /* hint from cmd_exec to do_match et al */
  699. X
  700. X#define Nullspat Null(SPAT*)
  701. !STUFFY!FUNK!
  702. echo Extracting t/op.undef
  703. sed >t/op.undef <<'!STUFFY!FUNK!' -e 's/X//'
  704. X#!./perl
  705. X
  706. X# $Header: op.undef,v 3.0 89/10/18 15:32:01 lwall Locked $
  707. X
  708. Xprint "1..21\n";
  709. X
  710. Xprint defined($a) ? "not ok 1\n" : "ok 1\n";
  711. X
  712. X$a = 1+1;
  713. Xprint defined($a) ? "ok 2\n" : "not ok 2\n";
  714. X
  715. Xundef $a;
  716. Xprint defined($a) ? "not ok 3\n" : "ok 3\n";
  717. X
  718. X$a = "hi";
  719. Xprint defined($a) ? "ok 4\n" : "not ok 4\n";
  720. X
  721. X$a = $b;
  722. Xprint defined($a) ? "not ok 5\n" : "ok 5\n";
  723. X
  724. X@ary = ("1arg");
  725. X$a = pop(@ary);
  726. Xprint defined($a) ? "ok 6\n" : "not ok 6\n";
  727. X$a = pop(@ary);
  728. Xprint defined($a) ? "not ok 7\n" : "ok 7\n";
  729. X
  730. X@ary = ("1arg");
  731. X$a = shift(@ary);
  732. Xprint defined($a) ? "ok 8\n" : "not ok 8\n";
  733. X$a = shift(@ary);
  734. Xprint defined($a) ? "not ok 9\n" : "ok 9\n";
  735. X
  736. X$ary{'foo'} = 'hi';
  737. Xprint defined($ary{'foo'}) ? "ok 10\n" : "not ok 10\n";
  738. Xprint defined($ary{'bar'}) ? "not ok 11\n" : "ok 11\n";
  739. Xundef $ary{'foo'};
  740. Xprint defined($ary{'foo'}) ? "not ok 12\n" : "ok 12\n";
  741. X
  742. Xprint defined(@ary) ? "ok 13\n" : "not ok 13\n";
  743. Xprint defined(%ary) ? "ok 14\n" : "not ok 14\n";
  744. Xundef @ary;
  745. Xprint defined(@ary) ? "not ok 15\n" : "ok 15\n";
  746. Xundef %ary;
  747. Xprint defined(%ary) ? "not ok 16\n" : "ok 16\n";
  748. X@ary = (1);
  749. Xprint defined @ary ? "ok 17\n" : "not ok 18\n";
  750. X%ary = (1,1);
  751. Xprint defined %ary ? "ok 18\n" : "not ok 18\n";
  752. X
  753. Xsub foo { print "ok 19\n"; }
  754. X
  755. X&foo || print "not ok 19\n";
  756. X
  757. Xprint defined &foo ? "ok 20\n" : "not ok 20\n";
  758. Xundef &foo;
  759. Xprint defined(&foo) ? "not ok 21\n" : "ok 21\n";
  760. !STUFFY!FUNK!
  761. echo Extracting eg/van/unvanish
  762. sed >eg/van/unvanish <<'!STUFFY!FUNK!' -e 's/X//'
  763. X#!/usr/bin/perl
  764. X
  765. X# $Header: unvanish,v 3.0 89/10/18 15:16:35 lwall Locked $
  766. X
  767. Xsub it {
  768. X    if ($olddir ne '.') {
  769. X    chop($pwd = `pwd`) if $pwd eq '';
  770. X    (chdir $olddir) || die "Directory $olddir is not accesible";
  771. X    }
  772. X    unless ($olddir eq '.deleted') {
  773. X    if (-d '.deleted') {
  774. X        chdir '.deleted' || die "Directory .deleted is not accesible";
  775. X    }
  776. X    else {
  777. X        chop($pwd = `pwd`) if $pwd eq '';
  778. X        die "Directory .deleted does not exist" unless $pwd =~ /\.deleted$/;
  779. X    }
  780. X    }
  781. X    print `mv $startfiles$filelist..$force`;
  782. X    if ($olddir ne '.') {
  783. X    (chdir $pwd) || die "Can't get back to original directory $pwd: $!\n";
  784. X    }
  785. X}
  786. X
  787. Xif ($#ARGV < 0) {
  788. X    open(lastcmd,'.deleted/.lastcmd') || 
  789. X    open(lastcmd,'.lastcmd') || 
  790. X        die "No previous vanish in this dir";
  791. X    $ARGV = <lastcmd>;
  792. X    close(lastcmd);
  793. X    @ARGV = split(/[\n ]+/,$ARGV);
  794. X}
  795. X
  796. Xwhile ($ARGV[0] =~ /^-/) {
  797. X    $_ = shift;
  798. X    /^-f/ && ($force = ' >/dev/null 2>&1');
  799. X    /^-i/ && ($interactive = 1);
  800. X    if (/^-+$/) {
  801. X    $startfiles = '- ';
  802. X    last;
  803. X    }
  804. X}
  805. X
  806. Xwhile ($file = shift) {
  807. X    if ($file =~ s|^(.*)/||) {
  808. X    $dir = $1;
  809. X    }
  810. X    else {
  811. X    $dir = '.';
  812. X    }
  813. X
  814. X    if ($dir ne $olddir) {
  815. X    do it() if $olddir;
  816. X    $olddir = $dir;
  817. X    }
  818. X
  819. X    if ($interactive) {
  820. X    print "unvanish: restore $dir/$file? ";
  821. X    next unless <stdin> =~ /^y/i;
  822. X    }
  823. X
  824. X    $filelist .= $file; $filelist .= ' ';
  825. X
  826. X}
  827. X
  828. Xdo it() if $olddir;
  829. !STUFFY!FUNK!
  830. echo Extracting eg/van/vanish
  831. sed >eg/van/vanish <<'!STUFFY!FUNK!' -e 's/X//'
  832. X#!/usr/bin/perl
  833. X
  834. X# $Header: vanish,v 3.0 89/10/18 15:16:46 lwall Locked $
  835. X
  836. Xsub it {
  837. X    if ($olddir ne '.') {
  838. X    chop($pwd = `pwd`) if $pwd eq '';
  839. X    (chdir $olddir) || die "Directory $olddir is not accesible";
  840. X    }
  841. X    if (!-d .deleted) {
  842. X    print `mkdir .deleted; chmod 775 .deleted`;
  843. X    die "You can't remove files from $olddir" if $?;
  844. X    }
  845. X    $filelist =~ s/ $//;
  846. X    $filelist =~ s/#/\\#/g;
  847. X    if ($filelist !~ /^[ \t]*$/) {
  848. X    open(lastcmd,'>.deleted/.lastcmd');
  849. X    print lastcmd $filelist,"\n";
  850. X    close(lastcmd);
  851. X    print `/bin/mv $startfiles$filelist .deleted$force`;
  852. X    }
  853. X    if ($olddir ne '.') {
  854. X    (chdir $pwd) || die "Can't get back to original directory $pwd: $!\n";
  855. X    }
  856. X}
  857. X
  858. Xwhile ($ARGV[0] =~ /^-/) {
  859. X    $_ = shift;
  860. X    /^-f/ && ($force = ' >/dev/null 2>&1');
  861. X    /^-i/ && ($interactive = 1);
  862. X    if (/^-+$/) {
  863. X    $startfiles = '- ';
  864. X    last;
  865. X    }
  866. X}
  867. X
  868. Xchop($pwd = `pwd`);
  869. X
  870. Xwhile ($file = shift) {
  871. X    if ($file =~ s|^(.*)/||) {
  872. X    $dir = $1;
  873. X    }
  874. X    else {
  875. X    $dir = '.';
  876. X    }
  877. X
  878. X    if ($interactive) {
  879. X    print "vanish: remove $dir/$file? ";
  880. X    next unless <stdin> =~ /^y/i;
  881. X    }
  882. X
  883. X    if ($file eq '.deleted') {
  884. X    print stderr "To delete .deleted (the trashcan) use the 'empty' command.\n";
  885. X    next;
  886. X    }
  887. X
  888. X    if ($dir ne $olddir) {
  889. X    do it() if $olddir;
  890. X    $olddir = $dir;
  891. X    }
  892. X
  893. X    $filelist .= $file; $filelist .= ' ';
  894. X}
  895. X
  896. Xdo it() if $olddir;
  897. !STUFFY!FUNK!
  898. echo Extracting eg/scan/scan_df
  899. sed >eg/scan/scan_df <<'!STUFFY!FUNK!' -e 's/X//'
  900. X#!/usr/bin/perl -P
  901. X
  902. X# $Header: scan_df,v 3.0 89/10/18 15:15:26 lwall Locked $
  903. X
  904. X# This report points out filesystems that are in danger of overflowing.
  905. X
  906. X(chdir '/usr/adm/private/memories') || die "Can't cd to memories: $!\n";
  907. X`df >newdf`;
  908. Xopen(Df, 'olddf');
  909. X
  910. Xwhile (<Df>) {
  911. X    ($fs,$kbytes,$used,$avail,$capacity,$mounted_on) = split;
  912. X    next if $fs =~ /:/;
  913. X    next if $fs eq '';
  914. X    $oldused{$fs} = $used;
  915. X}
  916. X
  917. Xopen(Df, 'newdf') || die "scan_df: can't open newdf";
  918. X
  919. Xwhile (<Df>) {
  920. X    ($fs,$kbytes,$used,$avail,$capacity,$mounted_on) = split;
  921. X    next if $fs =~ /:/;
  922. X    next if $fs eq '';
  923. X    $oldused = $oldused{$fs};
  924. X    next if ($oldused == $used && $capacity < 99);    # inactive filesystem
  925. X    if ($capacity >= 90) {
  926. X#if defined(mc300) || defined(mc500) || defined(mc700)
  927. X    $_ = substr($_,0,13) . '        ' . substr($_,13,1000);
  928. X    $kbytes /= 2;        # translate blocks to K
  929. X    $used /= 2;
  930. X    $oldused /= 2;
  931. X    $avail /= 2;
  932. X#endif
  933. X    $diff = int($used - $oldused);
  934. X    if ($avail < $diff * 2) {    # mark specially if in danger
  935. X        $mounted_on .= ' *';
  936. X    }
  937. X    next if $diff < 50 && $mounted_on eq '/';
  938. X    $fs =~ s|/dev/||;
  939. X    if ($diff >= 0) {
  940. X        $diff = '(+' . $diff . ')';
  941. X    }
  942. X    else {
  943. X        $diff = '(' . $diff . ')';
  944. X    }
  945. X    printf "%-8s%8d%8d %-8s%8d%7s    %s\n",
  946. X        $fs,$kbytes,$used,$diff,$avail,$capacity,$mounted_on;
  947. X    }
  948. X}
  949. X
  950. Xrename('newdf','olddf');
  951. !STUFFY!FUNK!
  952. echo Extracting eg/scan/scan_last
  953. sed >eg/scan/scan_last <<'!STUFFY!FUNK!' -e 's/X//'
  954. X#!/usr/bin/perl -P
  955. X
  956. X# $Header: scan_last,v 3.0 89/10/18 15:15:31 lwall Locked $
  957. X
  958. X# This reports who was logged on at weird hours
  959. X
  960. X($dy, $mo, $lastdt) = split(/ +/,`date`);
  961. X
  962. Xopen(Last, 'exec last 2>&1 |') || die "scan_last: can't run last";
  963. X
  964. Xwhile (<Last>) {
  965. X#if defined(mc300) || defined(mc500) || defined(mc700)
  966. X    $_ = substr($_,0,19) . substr($_,23,100);
  967. X#endif
  968. X    next if /^$/;
  969. X    (print),next if m|^/|;
  970. X    $login  = substr($_,0,8);
  971. X    $tty    = substr($_,10,7);
  972. X    $from   = substr($_,19,15);
  973. X    $day    = substr($_,36,3);
  974. X    $mo     = substr($_,40,3);
  975. X    $dt     = substr($_,44,2);
  976. X    $hr     = substr($_,47,2);
  977. X    $min    = substr($_,50,2);
  978. X    $dash   = substr($_,53,1);
  979. X    $tohr   = substr($_,55,2);
  980. X    $tomin  = substr($_,58,2);
  981. X    $durhr  = substr($_,63,2);
  982. X    $durmin = substr($_,66,2);
  983. X    
  984. X    next unless $hr;
  985. X    next if $login eq 'reboot  ';
  986. X    next if $login eq 'shutdown';
  987. X
  988. X    if ($dt != $lastdt) {
  989. X    if ($lastdt < $dt) {
  990. X        $seen += $dt - $lastdt;
  991. X    }
  992. X    else {
  993. X        $seen++;
  994. X    }
  995. X    $lastdt = $dt;
  996. X    }
  997. X
  998. X    $inat = $hr + $min / 60;
  999. X    if ($tohr =~ /^[a-z]/) {
  1000. X    $outat = 12;        # something innocuous
  1001. X    } else {
  1002. X    $outat = $tohr + $tomin / 60;
  1003. X    }
  1004. X
  1005. X  last if $seen + ($inat < 8) > 1;
  1006. X
  1007. X    if ($inat < 5 || $inat > 21 || $outat < 6 || $outat > 23) {
  1008. X    print;
  1009. X    }
  1010. X}
  1011. !STUFFY!FUNK!
  1012. echo Extracting makedir.SH
  1013. sed >makedir.SH <<'!STUFFY!FUNK!' -e 's/X//'
  1014. Xcase $CONFIG in
  1015. X'')
  1016. X    if test ! -f config.sh; then
  1017. X    ln ../config.sh . || \
  1018. X    ln ../../config.sh . || \
  1019. X    ln ../../../config.sh . || \
  1020. X    (echo "Can't find config.sh."; exit 1)
  1021. X    fi
  1022. X    . ./config.sh
  1023. X    ;;
  1024. Xesac
  1025. Xcase "$0" in
  1026. X*/*) cd `expr X$0 : 'X\(.*\)/'` ;;
  1027. Xesac
  1028. Xecho "Extracting makedir (with variable substitutions)"
  1029. X$spitshell >makedir <<!GROK!THIS!
  1030. X$startsh
  1031. X# $Header: makedir.SH,v 3.0 89/10/18 15:20:27 lwall Locked $
  1032. X# 
  1033. X# $Log:    makedir.SH,v $
  1034. X# Revision 3.0  89/10/18  15:20:27  lwall
  1035. X# 3.0 baseline
  1036. X# 
  1037. X
  1038. Xexport PATH || (echo "OOPS, this isn't sh.  Desperation time.  I will feed myself to sh."; sh \$0; kill \$\$)
  1039. X
  1040. Xcase \$# in
  1041. X  0)
  1042. X    $echo "makedir pathname filenameflag"
  1043. X    exit 1
  1044. X    ;;
  1045. Xesac
  1046. X
  1047. X: guarantee one slash before 1st component
  1048. Xcase \$1 in
  1049. X  /*) ;;
  1050. X  *)  set ./\$1 \$2 ;;
  1051. Xesac
  1052. X
  1053. X: strip last component if it is to be a filename
  1054. Xcase X\$2 in
  1055. X  X1) set \`$echo \$1 | $sed 's:\(.*\)/[^/]*\$:\1:'\` ;;
  1056. X  *)  set \$1 ;;
  1057. Xesac
  1058. X
  1059. X: return reasonable status if nothing to be created
  1060. Xif $test -d "\$1" ; then
  1061. X    exit 0
  1062. Xfi
  1063. X
  1064. Xlist=''
  1065. Xwhile true ; do
  1066. X    case \$1 in
  1067. X    */*)
  1068. X    list="\$1 \$list"
  1069. X    set \`echo \$1 | $sed 's:\(.*\)/:\1 :'\`
  1070. X    ;;
  1071. X    *)
  1072. X    break
  1073. X    ;;
  1074. X    esac
  1075. Xdone
  1076. X
  1077. Xset \$list
  1078. X
  1079. Xfor dir do
  1080. X    $mkdir \$dir >/dev/null 2>&1
  1081. Xdone
  1082. X!GROK!THIS!
  1083. X$eunicefix makedir
  1084. Xchmod +x makedir
  1085. !STUFFY!FUNK!
  1086. echo Extracting x2p/hash.h
  1087. sed >x2p/hash.h <<'!STUFFY!FUNK!' -e 's/X//'
  1088. X/* $Header: hash.h,v 3.0 89/10/18 15:34:57 lwall Locked $
  1089. X *
  1090. X *    Copyright (c) 1989, Larry Wall
  1091. X *
  1092. X *    You may distribute under the terms of the GNU General Public License
  1093. X *    as specified in the README file that comes with the perl 3.0 kit.
  1094. X *
  1095. X * $Log:    hash.h,v $
  1096. X * Revision 3.0  89/10/18  15:34:57  lwall
  1097. X * 3.0 baseline
  1098. X * 
  1099. X */
  1100. X
  1101. X#define FILLPCT 60        /* don't make greater than 99 */
  1102. X
  1103. X#ifdef DOINIT
  1104. Xchar coeff[] = {
  1105. X        61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1,
  1106. X        61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1,
  1107. X        61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1,
  1108. X        61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1,
  1109. X        61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1,
  1110. X        61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1,
  1111. X        61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1,
  1112. X        61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1};
  1113. X#else
  1114. Xextern char coeff[];
  1115. X#endif
  1116. X
  1117. Xtypedef struct hentry HENT;
  1118. X
  1119. Xstruct hentry {
  1120. X    HENT    *hent_next;
  1121. X    char    *hent_key;
  1122. X    STR        *hent_val;
  1123. X    int        hent_hash;
  1124. X};
  1125. X
  1126. Xstruct htbl {
  1127. X    HENT    **tbl_array;
  1128. X    int        tbl_max;
  1129. X    int        tbl_fill;
  1130. X    int        tbl_riter;    /* current root of iterator */
  1131. X    HENT    *tbl_eiter;    /* current entry of iterator */
  1132. X};
  1133. X
  1134. XSTR *hfetch();
  1135. Xbool hstore();
  1136. Xbool hdelete();
  1137. XHASH *hnew();
  1138. Xint hiterinit();
  1139. XHENT *hiternext();
  1140. Xchar *hiterkey();
  1141. XSTR *hiterval();
  1142. !STUFFY!FUNK!
  1143. echo Extracting t/comp.term
  1144. sed >t/comp.term <<'!STUFFY!FUNK!' -e 's/X//'
  1145. X#!./perl
  1146. X
  1147. X# $Header: comp.term,v 3.0 89/10/18 15:26:04 lwall Locked $
  1148. X
  1149. X# tests that aren't important enough for base.term
  1150. X
  1151. Xprint "1..14\n";
  1152. X
  1153. X$x = "\\n";
  1154. Xprint "#1\t:$x: eq " . ':\n:' . "\n";
  1155. Xif ($x eq '\n') {print "ok 1\n";} else {print "not ok 1\n";}
  1156. X
  1157. X$x = "#2\t:$x: eq :\\n:\n";
  1158. Xprint $x;
  1159. Xunless (index($x,'\\\\')>0) {print "ok 2\n";} else {print "not ok 2\n";}
  1160. X
  1161. Xif (length('\\\\') == 2) {print "ok 3\n";} else {print "not ok 3\n";}
  1162. X
  1163. X$one = 'a';
  1164. X
  1165. Xif (length("\\n") == 2) {print "ok 4\n";} else {print "not ok 4\n";}
  1166. Xif (length("\\\n") == 2) {print "ok 5\n";} else {print "not ok 5\n";}
  1167. Xif (length("$one\\n") == 3) {print "ok 6\n";} else {print "not ok 6\n";}
  1168. Xif (length("$one\\\n") == 3) {print "ok 7\n";} else {print "not ok 7\n";}
  1169. Xif (length("\\n$one") == 3) {print "ok 8\n";} else {print "not ok 8\n";}
  1170. Xif (length("\\\n$one") == 3) {print "ok 9\n";} else {print "not ok 9\n";}
  1171. Xif (length("\\${one}") == 2) {print "ok 10\n";} else {print "not ok 10\n";}
  1172. X
  1173. Xif ("${one}b" eq "ab") { print "ok 11\n";} else {print "not ok 11\n";}
  1174. X
  1175. X@foo = (1,2,3);
  1176. Xif ("$foo[1]b" eq "2b") { print "ok 12\n";} else {print "not ok 12\n";}
  1177. Xif ("@foo[0..1]b" eq "1 2b") { print "ok 13\n";} else {print "not ok 13\n";}
  1178. X$" = '::';
  1179. Xif ("@foo[0..1]b" eq "1::2b") { print "ok 14\n";} else {print "not ok 14\n";}
  1180. !STUFFY!FUNK!
  1181. echo Extracting t/io.tell
  1182. sed >t/io.tell <<'!STUFFY!FUNK!' -e 's/X//'
  1183. X#!./perl
  1184. X
  1185. X# $Header: io.tell,v 3.0 89/10/18 15:26:45 lwall Locked $
  1186. X
  1187. Xprint "1..13\n";
  1188. X
  1189. X$TST = 'tst';
  1190. X
  1191. Xopen($TST, '../Makefile') || (die "Can't open ../Makefile");
  1192. X
  1193. Xif (eof(tst)) { print "not ok 1\n"; } else { print "ok 1\n"; }
  1194. X
  1195. X$firstline = <$TST>;
  1196. X$secondpos = tell;
  1197. X
  1198. X$x = 0;
  1199. Xwhile (<tst>) {
  1200. X    if (eof) {$x++;}
  1201. X}
  1202. Xif ($x == 1) { print "ok 2\n"; } else { print "not ok 2\n"; }
  1203. X
  1204. X$lastpos = tell;
  1205. X
  1206. Xunless (eof) { print "not ok 3\n"; } else { print "ok 3\n"; }
  1207. X
  1208. Xif (seek($TST,0,0)) { print "ok 4\n"; } else { print "not ok 4\n"; }
  1209. X
  1210. Xif (eof) { print "not ok 5\n"; } else { print "ok 5\n"; }
  1211. X
  1212. Xif ($firstline eq <tst>) { print "ok 6\n"; } else { print "not ok 6\n"; }
  1213. X
  1214. Xif ($secondpos == tell) { print "ok 7\n"; } else { print "not ok 7\n"; }
  1215. X
  1216. Xif (seek(tst,0,1)) { print "ok 8\n"; } else { print "not ok 8\n"; }
  1217. X
  1218. Xif (eof($TST)) { print "not ok 9\n"; } else { print "ok 9\n"; }
  1219. X
  1220. Xif ($secondpos == tell) { print "ok 10\n"; } else { print "not ok 10\n"; }
  1221. X
  1222. Xif (seek(tst,0,2)) { print "ok 11\n"; } else { print "not ok 11\n"; }
  1223. X
  1224. Xif ($lastpos == tell) { print "ok 12\n"; } else { print "not ok 12\n"; }
  1225. X
  1226. Xunless (eof) { print "not ok 13\n"; } else { print "ok 13\n"; }
  1227. !STUFFY!FUNK!
  1228. echo Extracting t/base.lex
  1229. sed >t/base.lex <<'!STUFFY!FUNK!' -e 's/X//'
  1230. X#!./perl
  1231. X
  1232. X# $Header: base.lex,v 3.0 89/10/18 15:24:24 lwall Locked $
  1233. X
  1234. Xprint "1..18\n";
  1235. X
  1236. X$ # this is the register <space>
  1237. X= 'x';
  1238. X
  1239. Xprint "#1    :$ : eq :x:\n";
  1240. Xif ($  eq 'x') {print "ok 1\n";} else {print "not ok 1\n";}
  1241. X
  1242. X$x = $#;    # this is the register $#
  1243. X
  1244. Xif ($x eq '') {print "ok 2\n";} else {print "not ok 2\n";}
  1245. X
  1246. X$x = $#x;
  1247. X
  1248. Xif ($x eq '-1') {print "ok 3\n";} else {print "not ok 3\n";}
  1249. X
  1250. X$x = '\\'; # ';
  1251. X
  1252. Xif (length($x) == 1) {print "ok 4\n";} else {print "not ok 4\n";}
  1253. X
  1254. Xeval 'while (0) {
  1255. X    print "foo\n";
  1256. X}
  1257. X/^/ && (print "ok 5\n");
  1258. X';
  1259. X
  1260. Xeval '$foo{1} / 1;';
  1261. Xif (!$@) {print "ok 6\n";} else {print "not ok 6\n";}
  1262. X
  1263. Xeval '$foo = 123+123.4+123e4+123.4E5+123.4e+5+.12;';
  1264. X
  1265. X$foo = int($foo * 100 + .5);
  1266. Xif ($foo eq 2591024652) {print "ok 7\n";} else {print "not ok 7\n";}
  1267. X
  1268. Xprint <<'EOF';
  1269. Xok 8
  1270. XEOF
  1271. X
  1272. X$foo = 'ok 9';
  1273. Xprint <<EOF;
  1274. X$foo
  1275. XEOF
  1276. X
  1277. Xeval <<\EOE, print $@;
  1278. Xprint <<'EOF';
  1279. Xok 10
  1280. XEOF
  1281. X
  1282. X$foo = 'ok 11';
  1283. Xprint <<EOF;
  1284. X$foo
  1285. XEOF
  1286. XEOE
  1287. X
  1288. Xprint <<`EOS` . <<\EOF;
  1289. Xecho ok 12
  1290. XEOS
  1291. Xok 13
  1292. XEOF
  1293. X
  1294. Xprint qq/ok 14\n/;
  1295. Xprint qq(ok 15\n);
  1296. X
  1297. Xprint qq
  1298. Xok 16\n
  1299. X;
  1300. X
  1301. Xprint q<ok 17
  1302. X>;
  1303. X
  1304. Xprint <<;   # Yow!
  1305. Xok 18
  1306. X
  1307. X# previous line intentionally left blank.
  1308. !STUFFY!FUNK!
  1309. echo Extracting eg/scan/scan_sudo
  1310. sed >eg/scan/scan_sudo <<'!STUFFY!FUNK!' -e 's/X//'
  1311. X#!/usr/bin/perl -P
  1312. X
  1313. X# $Header: scan_sudo,v 3.0 89/10/18 15:15:52 lwall Locked $
  1314. X
  1315. X# Analyze the sudo log.
  1316. X
  1317. Xchdir('/usr/adm/private/memories') || die "Can't cd to memories: $!\n";
  1318. X
  1319. Xif (open(Oldsudo,'oldsudo')) {
  1320. X    $maxpos = <Oldsudo>;
  1321. X    close Oldsudo;
  1322. X}
  1323. Xelse {
  1324. X    $maxpos = 0;
  1325. X    `echo 0 >oldsudo`;
  1326. X}
  1327. X
  1328. Xunless (open(Sudo, '/usr/adm/sudo.log')) {
  1329. X    print "Somebody removed sudo.log!!!\n" if $maxpos;
  1330. X    exit 0;
  1331. X}
  1332. X
  1333. X($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
  1334. X   $blksize,$blocks) = stat(Sudo);
  1335. X
  1336. Xif ($size < $maxpos) {
  1337. X    $maxpos = 0;
  1338. X    print "Somebody reset sudo.log!!!\n";
  1339. X}
  1340. X
  1341. Xseek(Sudo,$maxpos,0);
  1342. X
  1343. Xwhile (<Sudo>) {
  1344. X    s/^.* :[ \t]+//;
  1345. X    s/ipcrm.*/ipcrm/;
  1346. X    s/kill.*/kill/;
  1347. X    unless ($seen{$_}++) {
  1348. X    push(@seen,$_);
  1349. X    }
  1350. X    $last = $_;
  1351. X}
  1352. X$max = tell(Sudo);
  1353. X
  1354. Xopen(tmp,'|sort >oldsudo.tmp') || die "Can't create tmp file: $!\n";
  1355. Xwhile ($_ = pop(@seen)) {
  1356. X    print tmp $_;
  1357. X}
  1358. Xclose(tmp);
  1359. Xopen(tmp,'oldsudo.tmp') || die "Can't reopen tmp file: $!\n";
  1360. Xwhile (<tmp>) {
  1361. X    print $seen{$_},":\t",$_;
  1362. X}
  1363. X
  1364. Xprint `(rm -f oldsudo.tmp; echo $max > oldsudo) 2>&1`;
  1365. !STUFFY!FUNK!
  1366. echo Extracting t/op.eval
  1367. sed >t/op.eval <<'!STUFFY!FUNK!' -e 's/X//'
  1368. X#!./perl
  1369. X
  1370. X# $Header: op.eval,v 3.0 89/10/18 15:28:53 lwall Locked $
  1371. X
  1372. Xprint "1..10\n";
  1373. X
  1374. Xeval 'print "ok 1\n";';
  1375. X
  1376. Xif ($@ eq '') {print "ok 2\n";} else {print "not ok 2\n";}
  1377. X
  1378. Xeval "\$foo\n    = # this is a comment\n'ok 3';";
  1379. Xprint $foo,"\n";
  1380. X
  1381. Xeval "\$foo\n    = # this is a comment\n'ok 4\n';";
  1382. Xprint $foo;
  1383. X
  1384. Xprint eval '
  1385. X$foo =';        # this tests for a call through yyerror()
  1386. Xif ($@ =~ /line 2/) {print "ok 5\n";} else {print "not ok 5\n";}
  1387. X
  1388. Xprint eval '$foo = /';    # this tests for a call through fatal()
  1389. Xif ($@ =~ /Search/) {print "ok 6\n";} else {print "not ok 6\n";}
  1390. X
  1391. Xprint eval '"ok 7\n";';
  1392. X
  1393. X# calculate a factorial with recursive evals
  1394. X
  1395. X$foo = 5;
  1396. X$fact = 'if ($foo <= 1) {1;} else {push(@x,$foo--); (eval $fact) * pop(@x);}';
  1397. X$ans = eval $fact;
  1398. Xif ($ans == 120) {print "ok 8\n";} else {print "not ok 8\n";}
  1399. X
  1400. X$foo = 5;
  1401. X$fact = 'local($foo)=$foo; $foo <= 1 ? 1 : $foo-- * (eval $fact);';
  1402. X$ans = eval $fact;
  1403. Xif ($ans == 120) {print "ok 9\n";} else {print "not ok 9 $ans\n";}
  1404. X
  1405. Xopen(try,'>Op.eval');
  1406. Xprint try 'print "ok 10\n"; unlink "Op.eval";',"\n";
  1407. Xclose try;
  1408. X
  1409. Xdo 'Op.eval'; print $@;
  1410. !STUFFY!FUNK!
  1411. echo Extracting x2p/str.h
  1412. sed >x2p/str.h <<'!STUFFY!FUNK!' -e 's/X//'
  1413. X/* $Header: str.h,v 3.0 89/10/18 15:35:27 lwall Locked $
  1414. X *
  1415. X *    Copyright (c) 1989, Larry Wall
  1416. X *
  1417. X *    You may distribute under the terms of the GNU General Public License
  1418. X *    as specified in the README file that comes with the perl 3.0 kit.
  1419. X *
  1420. X * $Log:    str.h,v $
  1421. X * Revision 3.0  89/10/18  15:35:27  lwall
  1422. X * 3.0 baseline
  1423. X * 
  1424. X */
  1425. X
  1426. Xstruct string {
  1427. X    char *    str_ptr;    /* pointer to malloced string */
  1428. X    double    str_nval;    /* numeric value, if any */
  1429. X    int        str_len;    /* allocated size */
  1430. X    int        str_cur;    /* length of str_ptr as a C string */
  1431. X    union {
  1432. X    STR *str_next;        /* while free, link to next free str */
  1433. X    } str_link;
  1434. X    char    str_pok;    /* state of str_ptr */
  1435. X    char    str_nok;    /* state of str_nval */
  1436. X};
  1437. X
  1438. X#define Nullstr Null(STR*)
  1439. X
  1440. X/* the following macro updates any magic values this str is associated with */
  1441. X
  1442. X#define STABSET(x) (x->str_link.str_magic && stabset(x->str_link.str_magic,x))
  1443. X
  1444. XEXT STR **tmps_list;
  1445. XEXT long tmps_max INIT(-1);
  1446. X
  1447. Xchar *str_2ptr();
  1448. Xdouble str_2num();
  1449. XSTR *str_static();
  1450. XSTR *str_make();
  1451. XSTR *str_nmake();
  1452. Xchar *str_gets();
  1453. !STUFFY!FUNK!
  1454. echo Extracting lib/look.pl
  1455. sed >lib/look.pl <<'!STUFFY!FUNK!' -e 's/X//'
  1456. X;# Usage: &look(*FILEHANDLE,$key,$dict,$fold)
  1457. X
  1458. X;# Sets file position in FILEHANDLE to be first line greater than or equal
  1459. X;# (stringwise) to $key.  Pass flags for dictionary order and case folding.
  1460. X
  1461. Xsub look {
  1462. X    local(*FH,$key,$fold) = @_;
  1463. X    local($max,$min,$mid,$_);
  1464. X    local($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
  1465. X       $blksize,$blocks) = stat(FH);
  1466. X    $blksize = 8192 unless $blksize;
  1467. X    $key =~ s/[^\w\s]//g if $dict;
  1468. X    $key =~ y/A-Z/a-z/ if $fold;
  1469. X    $max = $size + $blksize - 1;
  1470. X    $max -= $size % $blksize;
  1471. X    while ($max - $min > $blksize) {
  1472. X    $mid = ($max + $min) / 2;
  1473. X    die "look: internal error"  if $mid % $blksize;
  1474. X    seek(FH,$mid,0);
  1475. X    $_ = <FH>;        # probably a partial line
  1476. X    $_ = <FH>;
  1477. X    chop;
  1478. X    s/[^\w\s]//g if $dict;
  1479. X    y/A-Z/a-z/ if $fold;
  1480. X    if ($_ lt $key) {
  1481. X        $min = $mid;
  1482. X    }
  1483. X    else {
  1484. X        $max = $mid;
  1485. X    }
  1486. X    }
  1487. X    seek(FH,$min,0);
  1488. X    while (<FH>) {
  1489. X    chop;
  1490. X    s/[^\w\s]//g if $dict;
  1491. X    y/A-Z/a-z/ if $fold;
  1492. X    last if $_ ge $key;
  1493. X    $min = tell(FH);
  1494. X    }
  1495. X    seek(FH,$min,0);
  1496. X    $min;
  1497. X}
  1498. X
  1499. X1;
  1500. !STUFFY!FUNK!
  1501. echo Extracting t/op.each
  1502. sed >t/op.each <<'!STUFFY!FUNK!' -e 's/X//'
  1503. X#!./perl
  1504. X
  1505. X# $Header: op.each,v 3.0 89/10/18 15:28:48 lwall Locked $
  1506. X
  1507. Xprint "1..3\n";
  1508. X
  1509. X$h{'abc'} = 'ABC';
  1510. X$h{'def'} = 'DEF';
  1511. X$h{'jkl','mno'} = "JKL\034MNO";
  1512. X$h{'a',2,3,4,5} = join("\034",'A',2,3,4,5);
  1513. X$h{'a'} = 'A';
  1514. X$h{'b'} = 'B';
  1515. X$h{'c'} = 'C';
  1516. X$h{'d'} = 'D';
  1517. X$h{'e'} = 'E';
  1518. X$h{'f'} = 'F';
  1519. X$h{'g'} = 'G';
  1520. X$h{'h'} = 'H';
  1521. X$h{'i'} = 'I';
  1522. X$h{'j'} = 'J';
  1523. X$h{'k'} = 'K';
  1524. X$h{'l'} = 'L';
  1525. X$h{'m'} = 'M';
  1526. X$h{'n'} = 'N';
  1527. X$h{'o'} = 'O';
  1528. X$h{'p'} = 'P';
  1529. X$h{'q'} = 'Q';
  1530. X$h{'r'} = 'R';
  1531. X$h{'s'} = 'S';
  1532. X$h{'t'} = 'T';
  1533. X$h{'u'} = 'U';
  1534. X$h{'v'} = 'V';
  1535. X$h{'w'} = 'W';
  1536. X$h{'x'} = 'X';
  1537. X$h{'y'} = 'Y';
  1538. X$h{'z'} = 'Z';
  1539. X
  1540. X@keys = keys %h;
  1541. X@values = values %h;
  1542. X
  1543. Xif ($#keys == 29 && $#values == 29) {print "ok 1\n";} else {print "not ok 1\n";}
  1544. X
  1545. Xwhile (($key,$value) = each(h)) {
  1546. X    if ($key eq $keys[$i] && $value eq $values[$i] && $key gt $value) {
  1547. X    $key =~ y/a-z/A-Z/;
  1548. X    $i++ if $key eq $value;
  1549. X    }
  1550. X}
  1551. X
  1552. Xif ($i == 30) {print "ok 2\n";} else {print "not ok 2\n";}
  1553. X
  1554. X@keys = ('blurfl', keys(%h), 'dyick');
  1555. Xif ($#keys == 31) {print "ok 3\n";} else {print "not ok 3\n";}
  1556. !STUFFY!FUNK!
  1557. echo Extracting t/op.time
  1558. sed >t/op.time <<'!STUFFY!FUNK!' -e 's/X//'
  1559. X#!./perl
  1560. X
  1561. X# $Header: op.time,v 3.0 89/10/18 15:31:56 lwall Locked $
  1562. X
  1563. Xprint "1..5\n";
  1564. X
  1565. X($beguser,$begsys) = times;
  1566. X
  1567. X$beg = time;
  1568. X
  1569. Xwhile (($now = time) == $beg) {}
  1570. X
  1571. Xif ($now > $beg && $now - $beg < 10){print "ok 1\n";} else {print "not ok 1\n";}
  1572. X
  1573. Xfor ($i = 0; $i < 100000; $i++) {
  1574. X    ($nowuser, $nowsys) = times;
  1575. X    $i = 200000 if $nowuser > $beguser && $nowsys > $begsys;
  1576. X    last if time - $beg > 20;
  1577. X}
  1578. X
  1579. Xif ($i >= 200000) {print "ok 2\n";} else {print "not ok 2\n";}
  1580. X
  1581. X($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($beg);
  1582. X($xsec,$foo) = localtime($now);
  1583. X$localyday = $yday;
  1584. X
  1585. Xif ($sec != $xsec && $mday && $year)
  1586. X    {print "ok 3\n";}
  1587. Xelse
  1588. X    {print "not ok 3\n";}
  1589. X
  1590. X($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = gmtime($beg);
  1591. X($xsec,$foo) = localtime($now);
  1592. X
  1593. Xif ($sec != $xsec && $mday && $year)
  1594. X    {print "ok 4\n";}
  1595. Xelse
  1596. X    {print "not ok 4\n";}
  1597. X
  1598. Xif (index(" :0:1:-1:365:366:-365:-366:",':' . ($localyday - $yday) . ':') > 0)
  1599. X    {print "ok 5\n";}
  1600. Xelse
  1601. X    {print "not ok 5\n";}
  1602. !STUFFY!FUNK!
  1603. echo Extracting lib/getopt.pl
  1604. sed >lib/getopt.pl <<'!STUFFY!FUNK!' -e 's/X//'
  1605. X;# $Header: getopt.pl,v 3.0 89/10/18 15:19:26 lwall Locked $
  1606. X
  1607. X;# Process single-character switches with switch clustering.  Pass one argument
  1608. X;# which is a string containing all switches that take an argument.  For each
  1609. X;# switch found, sets $opt_x (where x is the switch name) to the value of the
  1610. X;# argument, or 1 if no argument.  Switches which take an argument don't care
  1611. X;# whether there is a space between the switch and the argument.
  1612. X
  1613. X;# Usage:
  1614. X;#    do Getopt('oDI');  # -o, -D & -I take arg.  Sets opt_* as a side effect.
  1615. X
  1616. Xsub Getopt {
  1617. X    local($argumentative) = @_;
  1618. X    local($_,$first,$rest);
  1619. X
  1620. X    while (($_ = $ARGV[0]) =~ /^-(.)(.*)/) {
  1621. X    ($first,$rest) = ($1,$2);
  1622. X    if (index($argumentative,$first) >= $[) {
  1623. X        if ($rest ne '') {
  1624. X        shift(@ARGV);
  1625. X        }
  1626. X        else {
  1627. X        shift(@ARGV);
  1628. X        $rest = shift(@ARGV);
  1629. X        }
  1630. X        eval "\$opt_$first = \$rest;";
  1631. X    }
  1632. X    else {
  1633. X        eval "\$opt_$first = 1;";
  1634. X        if ($rest ne '') {
  1635. X        $ARGV[0] = "-$rest";
  1636. X        }
  1637. X        else {
  1638. X        shift(@ARGV);
  1639. X        }
  1640. X    }
  1641. X    }
  1642. X}
  1643. X
  1644. X1;
  1645. !STUFFY!FUNK!
  1646. echo Extracting t/op.do
  1647. sed >t/op.do <<'!STUFFY!FUNK!' -e 's/X//'
  1648. X#!./perl
  1649. X
  1650. X# $Header: op.do,v 3.0 89/10/18 15:28:43 lwall Locked $
  1651. X
  1652. Xsub foo1
  1653. X{
  1654. X    print $_[0];
  1655. X    'value';
  1656. X}
  1657. X
  1658. Xsub foo2
  1659. X{
  1660. X    shift(_);
  1661. X    print $_[0];
  1662. X    $x = 'value';
  1663. X    $x;
  1664. X}
  1665. X
  1666. Xprint "1..15\n";
  1667. X
  1668. X$_[0] = "not ok 1\n";
  1669. X$result = do foo1("ok 1\n");
  1670. Xprint "#2\t:$result: eq :value:\n";
  1671. Xif ($result EQ 'value') { print "ok 2\n"; } else { print "not ok 2\n"; }
  1672. Xif ($_[0] EQ "not ok 1\n") { print "ok 3\n"; } else { print "not ok 3\n"; }
  1673. X
  1674. X$_[0] = "not ok 4\n";
  1675. X$result = do foo2("not ok 4\n","ok 4\n","not ok 4\n");
  1676. Xprint "#5\t:$result: eq :value:\n";
  1677. Xif ($result EQ 'value') { print "ok 5\n"; } else { print "not ok 5\n"; }
  1678. Xif ($_[0] EQ "not ok 4\n") { print "ok 6\n"; } else { print "not ok 6\n"; }
  1679. X
  1680. X$result = do{print "ok 7\n"; 'value';};
  1681. Xprint "#8\t:$result: eq :value:\n";
  1682. Xif ($result EQ 'value') { print "ok 8\n"; } else { print "not ok 8\n"; }
  1683. X
  1684. Xsub blather {
  1685. X    print @_;
  1686. X}
  1687. X
  1688. Xdo blather("ok 9\n","ok 10\n");
  1689. X@x = ("ok 11\n", "ok 12\n");
  1690. X@y = ("ok 14\n", "ok 15\n");
  1691. Xdo blather(@x,"ok 13\n",@y);
  1692. !STUFFY!FUNK!
  1693. echo Extracting regexp.h
  1694. sed >regexp.h <<'!STUFFY!FUNK!' -e 's/X//'
  1695. X/*
  1696. X * Definitions etc. for regexp(3) routines.
  1697. X *
  1698. X * Caveat:  this is V8 regexp(3) [actually, a reimplementation thereof],
  1699. X * not the System V one.
  1700. X */
  1701. X
  1702. X/* $Header: regexp.h,v 3.0 89/10/18 15:22:46 lwall Locked $
  1703. X *
  1704. X * $Log:    regexp.h,v $
  1705. X * Revision 3.0  89/10/18  15:22:46  lwall
  1706. X * 3.0 baseline
  1707. X * 
  1708. X */
  1709. X
  1710. X#define NSUBEXP  10
  1711. X
  1712. Xtypedef struct regexp {
  1713. X    char *startp[NSUBEXP];
  1714. X    char *endp[NSUBEXP];
  1715. X    STR *regstart;        /* Internal use only. */
  1716. X    char *regstclass;
  1717. X    STR *regmust;        /* Internal use only. */
  1718. X    int regback;        /* Can regmust locate first try? */
  1719. X    char *precomp;        /* pre-compilation regular expression */
  1720. X    char *subbase;        /* saved string so \digit works forever */
  1721. X    char reganch;        /* Internal use only. */
  1722. X    char do_folding;    /* do case-insensitive match? */
  1723. X    char lastparen;        /* last paren matched */
  1724. X    char nparens;        /* number of parentheses */
  1725. X    char program[1];    /* Unwarranted chumminess with compiler. */
  1726. X} regexp;
  1727. X
  1728. Xregexp *regcomp();
  1729. Xint regexec();
  1730. !STUFFY!FUNK!
  1731. echo Extracting t/cmd.for
  1732. sed >t/cmd.for <<'!STUFFY!FUNK!' -e 's/X//'
  1733. X#!./perl
  1734. X
  1735. X# $Header: cmd.for,v 3.0 89/10/18 15:24:43 lwall Locked $
  1736. X
  1737. Xprint "1..7\n";
  1738. X
  1739. Xfor ($i = 0; $i <= 10; $i++) {
  1740. X    $x[$i] = $i;
  1741. X}
  1742. X$y = $x[10];
  1743. Xprint "#1    :$y: eq :10:\n";
  1744. X$y = join(' ', @x);
  1745. Xprint "#1    :$y: eq :0 1 2 3 4 5 6 7 8 9 10:\n";
  1746. Xif (join(' ', @x) eq '0 1 2 3 4 5 6 7 8 9 10') {
  1747. X    print "ok 1\n";
  1748. X} else {
  1749. X    print "not ok 1\n";
  1750. X}
  1751. X
  1752. X$i = $c = 0;
  1753. Xfor (;;) {
  1754. X    $c++;
  1755. X    last if $i++ > 10;
  1756. X}
  1757. Xif ($c == 12) {print "ok 2\n";} else {print "not ok 2\n";}
  1758. X
  1759. X$foo = 3210;
  1760. X@ary = (1,2,3,4,5);
  1761. Xforeach $foo (@ary) {
  1762. X    $foo *= 2;
  1763. X}
  1764. Xif (join('',@ary) eq '246810') {print "ok 3\n";} else {print "not ok 3\n";}
  1765. X
  1766. Xfor (@ary) {
  1767. X    s/(.*)/ok $1\n/;
  1768. X}
  1769. X
  1770. Xprint $ary[1];
  1771. X
  1772. X# test for internal scratch array generation
  1773. X# this also tests that $foo was restored to 3210 after test 3
  1774. Xfor (split(' ','a b c d e')) {
  1775. X    $foo .= $_;
  1776. X}
  1777. Xif ($foo eq '3210abcde') {print "ok 5\n";} else {print "not ok 5 $foo\n";}
  1778. X
  1779. Xforeach $foo (("ok 6\n","ok 7\n")) {
  1780. X    print $foo;
  1781. X}
  1782. !STUFFY!FUNK!
  1783. echo Extracting t/op.magic
  1784. sed >t/op.magic <<'!STUFFY!FUNK!' -e 's/X//'
  1785. X#!./perl
  1786. X
  1787. X# $Header: op.magic,v 3.0 89/10/18 15:29:54 lwall Locked $
  1788. X
  1789. X$| = 1;        # command buffering
  1790. X
  1791. Xprint "1..5\n";
  1792. X
  1793. Xeval '$ENV{"foo"} = "hi there";';    # check that ENV is inited inside eval
  1794. Xif (`echo \$foo` eq "hi there\n") {print "ok 1\n";} else {print "not ok 1\n";}
  1795. X
  1796. X$! = 0;
  1797. Xopen(foo,'ajslkdfpqjsjfkslkjdflksd');
  1798. Xif ($! == 2) {print "ok 2\n";} else {print "not ok 2\n";}
  1799. X
  1800. X# the next tests are embedded inside system simply because sh spits out
  1801. X# a newline onto stderr when a child process kills itself with SIGINT.
  1802. X
  1803. Xsystem './perl',
  1804. X'-e', '$| = 1;        # command buffering',
  1805. X
  1806. X'-e', '$SIG{"INT"} = "ok3"; kill 2,$$;',
  1807. X'-e', '$SIG{"INT"} = "IGNORE"; kill 2,$$; print "ok 4\n";',
  1808. X'-e', '$SIG{"INT"} = "DEFAULT"; kill 2,$$; print "not ok\n";',
  1809. X
  1810. X'-e', 'sub ok3 { print "ok 3\n" if pop(@_) eq "INT"; }';
  1811. X
  1812. X@val1 = @ENV{keys(%ENV)};    # can we slice ENV?
  1813. X@val2 = values(%ENV);
  1814. X
  1815. Xprint join(':',@val1) eq join(':',@val2) ? "ok 5\n" : "not ok 5\n";
  1816. !STUFFY!FUNK!
  1817. echo Extracting t/op.repeat
  1818. sed >t/op.repeat <<'!STUFFY!FUNK!' -e 's/X//'
  1819. X#!./perl
  1820. X
  1821. X# $Header: op.repeat,v 3.0 89/10/18 15:31:07 lwall Locked $
  1822. X
  1823. Xprint "1..11\n";
  1824. X
  1825. X# compile time
  1826. X
  1827. Xif ('-' x 5 eq '-----') {print "ok 1\n";} else {print "not ok 1\n";}
  1828. Xif ('-' x 1 eq '-') {print "ok 2\n";} else {print "not ok 2\n";}
  1829. Xif ('-' x 0 eq '') {print "ok 3\n";} else {print "not ok 3\n";}
  1830. X
  1831. Xif ('ab' x 3 eq 'ababab') {print "ok 4\n";} else {print "not ok 4\n";}
  1832. X
  1833. X# run time
  1834. X
  1835. X$a = '-';
  1836. Xif ($a x 5 eq '-----') {print "ok 5\n";} else {print "not ok 5\n";}
  1837. Xif ($a x 1 eq '-') {print "ok 6\n";} else {print "not ok 6\n";}
  1838. Xif ($a x 0 eq '') {print "ok 7\n";} else {print "not ok 7\n";}
  1839. X
  1840. X$a = 'ab';
  1841. Xif ($a x 3 eq 'ababab') {print "ok 8\n";} else {print "not ok 8\n";}
  1842. X
  1843. X$a = 'xyz';
  1844. X$a x= 2;
  1845. Xif ($a eq 'xyzxyz') {print "ok 9\n";} else {print "not ok 9\n";}
  1846. X$a x= 1;
  1847. Xif ($a eq 'xyzxyz') {print "ok 10\n";} else {print "not ok 10\n";}
  1848. X$a x= 0;
  1849. Xif ($a eq '') {print "ok 11\n";} else {print "not ok 11\n";}
  1850. X
  1851. !STUFFY!FUNK!
  1852. echo Extracting t/io.argv
  1853. sed >t/io.argv <<'!STUFFY!FUNK!' -e 's/X//'
  1854. X#!./perl
  1855. X
  1856. X# $Header: io.argv,v 3.0 89/10/18 15:26:10 lwall Locked $
  1857. X
  1858. Xprint "1..5\n";
  1859. X
  1860. Xopen(try, '>Io.argv.tmp') || (die "Can't open temp file.");
  1861. Xprint try "a line\n";
  1862. Xclose try;
  1863. X
  1864. X$x = `./perl -e 'while (<>) {print \$.,\$_;}' Io.argv.tmp Io.argv.tmp`;
  1865. X
  1866. Xif ($x eq "1a line\n2a line\n") {print "ok 1\n";} else {print "not ok 1\n";}
  1867. X
  1868. X$x = `echo foo|./perl -e 'while (<>) {print $_;}' Io.argv.tmp -`;
  1869. X
  1870. Xif ($x eq "a line\nfoo\n") {print "ok 2\n";} else {print "not ok 2\n";}
  1871. X
  1872. X$x = `echo foo|./perl -e 'while (<>) {print $_;}'`;
  1873. X
  1874. Xif ($x eq "foo\n") {print "ok 3\n";} else {print "not ok 3\n";}
  1875. X
  1876. X@ARGV = ('Io.argv.tmp', 'Io.argv.tmp', '/dev/null', 'Io.argv.tmp');
  1877. Xwhile (<>) {
  1878. X    $y .= $. . $_;
  1879. X    if (eof()) {
  1880. X    if ($. == 3) {print "ok 4\n";} else {print "not ok 4\n";}
  1881. X    }
  1882. X}
  1883. X
  1884. Xif ($y eq "1a line\n2a line\n3a line\n")
  1885. X    {print "ok 5\n";}
  1886. Xelse
  1887. X    {print "not ok 5\n";}
  1888. X
  1889. X`/bin/rm -f Io.argv.tmp`;
  1890. !STUFFY!FUNK!
  1891. echo Extracting eg/changes
  1892. sed >eg/changes <<'!STUFFY!FUNK!' -e 's/X//'
  1893. X#!/usr/bin/perl -P
  1894. X
  1895. X# $Header: changes,v 3.0 89/10/18 15:13:23 lwall Locked $
  1896. X
  1897. X($dir, $days) = @ARGV;
  1898. X$dir = '/' if $dir eq '';
  1899. X$days = '14' if $days eq '';
  1900. X
  1901. X# Masscomps do things differently from Suns
  1902. X
  1903. X#if defined(mc300) || defined(mc500) || defined(mc700)
  1904. Xopen(Find, "find $dir -mtime -$days -print |") ||
  1905. X    die "changes: can't run find";
  1906. X#else
  1907. Xopen(Find, "find $dir \\( -fstype nfs -prune \\) -o -mtime -$days -ls |") ||
  1908. X    die "changes: can't run find";
  1909. X#endif
  1910. X
  1911. Xwhile (<Find>) {
  1912. X
  1913. X#if defined(mc300) || defined(mc500) || defined(mc700)
  1914. X    $x = `/bin/ls -ild $_`;
  1915. X    $_ = $x;
  1916. X    ($inode,$perm,$links,$owner,$group,$size,$month,$day,$time,$name)
  1917. X      = split(' ');
  1918. X#else
  1919. X    ($inode,$blocks,$perm,$links,$owner,$group,$size,$month,$day,$time,$name)
  1920. X      = split(' ');
  1921. X#endif
  1922. X
  1923. X    printf("%10s%3s %-8s %-8s%9s %3s %2s %s\n",
  1924. X        $perm,$links,$owner,$group,$size,$month,$day,$name);
  1925. X}
  1926. X
  1927. !STUFFY!FUNK!
  1928. echo Extracting eg/myrup
  1929. sed >eg/myrup <<'!STUFFY!FUNK!' -e 's/X//'
  1930. X#!/usr/bin/perl
  1931. X
  1932. X# $Header: myrup,v 3.0 89/10/18 15:15:06 lwall Locked $
  1933. X
  1934. X# This was a customization of ruptime requested by someone here who wanted
  1935. X# to be able to find the least loaded machine easily.  It uses the
  1936. X# /etc/ghosts file that's defined for gsh and gcp to prune down the
  1937. X# number of entries to those hosts we have administrative control over.
  1938. X
  1939. Xprint "node    load (u)\n------- --------\n";
  1940. X
  1941. Xopen(ghosts,'/etc/ghosts') || die "Can't open /etc/ghosts: $!";
  1942. Xline: while (<ghosts>) {
  1943. X    next line if /^#/;
  1944. X    next line if /^$/;
  1945. X    next line if /=/;
  1946. X    ($host) = split;
  1947. X    $wanted{$host} = 1;
  1948. X}
  1949. X
  1950. Xopen(ruptime,'ruptime|') || die "Can't run ruptime: $!";
  1951. Xopen(sort,'|sort +1n');
  1952. X
  1953. Xwhile (<ruptime>) {
  1954. X    ($host,$upness,$foo,$users,$foo,$foo,$load) = split(/[\s,]+/);
  1955. X    if ($wanted{$host} && $upness eq 'up') {
  1956. X    printf sort "%s\t%s (%d)\n", $host, $load, $users;
  1957. X    }
  1958. X}
  1959. !STUFFY!FUNK!
  1960. echo Extracting eg/shmkill
  1961. sed >eg/shmkill <<'!STUFFY!FUNK!' -e 's/X//'
  1962. X#!/usr/bin/perl
  1963. X
  1964. X# $Header: shmkill,v 3.0 89/10/18 15:16:09 lwall Locked $
  1965. X
  1966. X# A script to call from crontab periodically when people are leaving shared
  1967. X# memory sitting around unattached.
  1968. X
  1969. Xopen(ipcs,'ipcs -m -o|') || die "Can't run ipcs: $!";
  1970. X
  1971. Xwhile (<ipcs>) {
  1972. X    $tmp = index($_,'NATTCH');
  1973. X    $pos = $tmp if $tmp >= 0;
  1974. X    if (/^m/) {
  1975. X    ($m,$id,$key,$mode,$owner,$group,$attach) = split;
  1976. X    if ($attach != substr($_,$pos,6)) {
  1977. X        die "Different ipcs format--can't parse!\n";
  1978. X    }
  1979. X    if ($attach == 0) {
  1980. X        push(@goners,'-m',$id);
  1981. X    }
  1982. X    }
  1983. X}
  1984. X
  1985. Xexec 'ipcrm', @goners if $#goners >= 0;
  1986. !STUFFY!FUNK!
  1987. echo ""
  1988. echo "End of kit 23 (of 24)"
  1989. cat /dev/null >kit23isdone
  1990. run=''
  1991. config=''
  1992. 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
  1993.     if test -f kit${iskit}isdone; then
  1994.     run="$run $iskit"
  1995.     else
  1996.     todo="$todo $iskit"
  1997.     fi
  1998. done
  1999. case $todo in
  2000.     '')
  2001.     echo "You have run all your kits.  Please read README and then type Configure."
  2002.     chmod 755 Configure
  2003.     ;;
  2004.     *)  echo "You have run$run."
  2005.     echo "You still need to run$todo."
  2006.     ;;
  2007. esac
  2008. : Someone might mail this, so...
  2009. exit
  2010.  
  2011.