home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1994 October / usenetsourcesnewsgroupsinfomagicoctober1994disk2.iso / unix / volume20 / perl3.0 / part22 < prev    next >
Encoding:
Internet Message Format  |  1989-11-01  |  49.0 KB
  1. Subject:  v20i105:  Perl, a language with features of C/sed/awk/shell/etc, Part22/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 105
  8. Archive-name: perl3.0/part22
  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 22 (of 24).  If kit 22 is complete, the line"
  16. echo '"'"End of kit 22 (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 lib t x2p 2>/dev/null
  20. echo Extracting lib/termcap.pl
  21. sed >lib/termcap.pl <<'!STUFFY!FUNK!' -e 's/X//'
  22. X;# $Header: termcap.pl,v 3.0 89/10/18 15:19:58 lwall Locked $
  23. X;#
  24. X;# Usage:
  25. X;#    do 'ioctl.pl';
  26. X;#    ioctl(TTY,$TIOCGETP,$foo);
  27. X;#    ($ispeed,$ospeed) = unpack('cc',$foo);
  28. X;#    do 'termcap.pl';
  29. X;#    do Tgetent('vt100');    # sets $TC{'cm'}, etc.
  30. X;#    do Tgoto($TC{'cm'},$row,$col);
  31. X;#    do Tputs($TC{'dl'},$affcnt,'FILEHANDLE');
  32. X;#
  33. Xsub Tgetent {
  34. X    local($TERM) = @_;
  35. X    local($TERMCAP,$_,$entry,$loop,$field);
  36. X
  37. X    warn "Tgetent: no ospeed set" unless $ospeed;
  38. X    foreach $key (keys(TC)) {
  39. X    delete $TC{$key};
  40. X    }
  41. X    $TERM = $ENV{'TERM'} unless $TERM;
  42. X    $TERMCAP = $ENV{'TERMCAP'};
  43. X    $TERMCAP = '/etc/termcap' unless $TERMCAP;
  44. X    if ($TERMCAP !~ m:^/:) {
  45. X    if (index($TERMCAP,"|$TERM|") < $[) {
  46. X        $TERMCAP = '/etc/termcap';
  47. X    }
  48. X    }
  49. X    if ($TERMCAP =~ m:^/:) {
  50. X    $entry = '';
  51. X    do {
  52. X        $loop = "
  53. X        open(TERMCAP,'<$TERMCAP') || die \"Can't open $TERMCAP\";
  54. X        while (<TERMCAP>) {
  55. X        next if /^#/;
  56. X        next if /^\t/;
  57. X        if (/\\|$TERM[:\\|]/) {
  58. X            chop;
  59. X            while (chop eq '\\\\') {
  60. X            \$_ .= <TERMCAP>;
  61. X            chop;
  62. X            }
  63. X            \$_ .= ':';
  64. X            last;
  65. X        }
  66. X        }
  67. X        close TERMCAP;
  68. X        \$entry .= \$_;
  69. X        ";
  70. X        eval $loop;
  71. X    } while s/:tc=([^:]+):/:/, $TERM = $1;
  72. X    $TERMCAP = $entry;
  73. X    }
  74. X
  75. X    foreach $field (split(/:[\s:\\]*/,$TERMCAP)) {
  76. X    if ($field =~ /^\w\w$/) {
  77. X        $TC{$field} = 1;
  78. X    }
  79. X    elsif ($field =~ /^(\w\w)#(.*)/) {
  80. X        $TC{$1} = $2 if $TC{$1} eq '';
  81. X    }
  82. X    elsif ($field =~ /^(\w\w)=(.*)/) {
  83. X        $entry = $1;
  84. X        $_ = $2;
  85. X        s/\\E/\033/g;
  86. X        s/\\(\d\d\d)/pack('c',$1 & 0177)/eg;
  87. X        s/\\n/\n/g;
  88. X        s/\\r/\r/g;
  89. X        s/\\t/\t/g;
  90. X        s/\\b/\b/g;
  91. X        s/\\f/\f/g;
  92. X        s/\\\^/\377/g;
  93. X        s/\^\?/\177/g;
  94. X        s/\^(.)/pack('c',$1 & 031)/eg;
  95. X        s/\\(.)/$1/g;
  96. X        s/\377/^/g;
  97. X        $TC{$entry} = $_ if $TC{$entry} eq '';
  98. X    }
  99. X    }
  100. X    $TC{'pc'} = "\0" if $TC{'pc'} eq '';
  101. X    $TC{'bc'} = "\b" if $TC{'bc'} eq '';
  102. X}
  103. X
  104. X@Tputs = (0,200,133.3,90.9,74.3,66.7,50,33.3,16.7,8.3,5.5,4.1,2,1,.5,.2);
  105. X
  106. Xsub Tputs {
  107. X    local($string,$affcnt,$FH) = @_;
  108. X    local($ms);
  109. X    if ($string =~ /(^[\d.]+)(\*?)(.*)$/) {
  110. X    $ms = $1;
  111. X    $ms *= $affcnt if $2;
  112. X    $string = $3;
  113. X    $decr = $Tputs[$ospeed];
  114. X    if ($decr > .1) {
  115. X        $ms += $decr / 2;
  116. X        $string .= $TC{'pc'} x ($ms / $decr);
  117. X    }
  118. X    }
  119. X    print $FH $string if $FH;
  120. X    $string;
  121. X}
  122. X
  123. Xsub Tgoto {
  124. X    local($string) = shift(@_);
  125. X    local($result) = '';
  126. X    local($after) = '';
  127. X    local($code,$tmp) = @_;
  128. X    @_ = ($tmp,$code);
  129. X    local($online) = 0;
  130. X    while ($string =~ /^([^%]*)%(.)(.*)/) {
  131. X    $result .= $1;
  132. X    $code = $2;
  133. X    $string = $3;
  134. X    if ($code eq 'd') {
  135. X        $result .= sprintf("%d",shift(@_));
  136. X    }
  137. X    elsif ($code eq '.') {
  138. X        $tmp = shift(@_);
  139. X        if ($tmp == 0 || $tmp == 4 || $tmp == 10) {
  140. X        if ($online) {
  141. X            ++$tmp, $after .= $TC{'up'} if $TC{'up'};
  142. X        }
  143. X        else {
  144. X            ++$tmp, $after .= $TC{'bc'};
  145. X        }
  146. X        }
  147. X        $result .= sprintf("%c",$tmp);
  148. X        $online = !$online;
  149. X    }
  150. X    elsif ($code eq '+') {
  151. X        $result .= sprintf("%c",shift(@_)+ord($string));
  152. X        $string = substr($string,1,99);
  153. X        $online = !$online;
  154. X    }
  155. X    elsif ($code eq 'r') {
  156. X        ($code,$tmp) = @_;
  157. X        @_ = ($tmp,$code);
  158. X        $online = !$online;
  159. X    }
  160. X    elsif ($code eq '>') {
  161. X        ($code,$tmp,$string) = unpack("CCa99",$string);
  162. X        if ($_[$[] > $code) {
  163. X        $_[$[] += $tmp;
  164. X        }
  165. X    }
  166. X    elsif ($code eq '2') {
  167. X        $result .= sprintf("%02d",shift(@_));
  168. X        $online = !$online;
  169. X    }
  170. X    elsif ($code eq '3') {
  171. X        $result .= sprintf("%03d",shift(@_));
  172. X        $online = !$online;
  173. X    }
  174. X    elsif ($code eq 'i') {
  175. X        ($code,$tmp) = @_;
  176. X        @_ = ($code+1,$tmp+1);
  177. X    }
  178. X    else {
  179. X        return "OOPS";
  180. X    }
  181. X    }
  182. X    $result . $string . $after;
  183. X}
  184. X
  185. X1;
  186. !STUFFY!FUNK!
  187. echo Extracting t/op.pat
  188. sed >t/op.pat <<'!STUFFY!FUNK!' -e 's/X//'
  189. X#!./perl
  190. X
  191. X# $Header: op.pat,v 3.0 89/10/18 15:30:44 lwall Locked $
  192. X
  193. Xprint "1..43\n";
  194. X
  195. X$x = "abc\ndef\n";
  196. X
  197. Xif ($x =~ /^abc/) {print "ok 1\n";} else {print "not ok 1\n";}
  198. Xif ($x !~ /^def/) {print "ok 2\n";} else {print "not ok 2\n";}
  199. X
  200. X$* = 1;
  201. Xif ($x =~ /^def/) {print "ok 3\n";} else {print "not ok 3\n";}
  202. X$* = 0;
  203. X
  204. X$_ = '123';
  205. Xif (/^([0-9][0-9]*)/) {print "ok 4\n";} else {print "not ok 4\n";}
  206. X
  207. Xif ($x =~ /^xxx/) {print "not ok 5\n";} else {print "ok 5\n";}
  208. Xif ($x !~ /^abc/) {print "not ok 6\n";} else {print "ok 6\n";}
  209. X
  210. Xif ($x =~ /def/) {print "ok 7\n";} else {print "not ok 7\n";}
  211. Xif ($x !~ /def/) {print "not ok 8\n";} else {print "ok 8\n";}
  212. X
  213. Xif ($x !~ /.def/) {print "ok 9\n";} else {print "not ok 9\n";}
  214. Xif ($x =~ /.def/) {print "not ok 10\n";} else {print "ok 10\n";}
  215. X
  216. Xif ($x =~ /\ndef/) {print "ok 11\n";} else {print "not ok 11\n";}
  217. Xif ($x !~ /\ndef/) {print "not ok 12\n";} else {print "ok 12\n";}
  218. X
  219. X$_ = 'aaabbbccc';
  220. Xif (/(a*b*)(c*)/ && $1 eq 'aaabbb' && $2 eq 'ccc') {
  221. X    print "ok 13\n";
  222. X} else {
  223. X    print "not ok 13\n";
  224. X}
  225. Xif (/(a+b+c+)/ && $1 eq 'aaabbbccc') {
  226. X    print "ok 14\n";
  227. X} else {
  228. X    print "not ok 14\n";
  229. X}
  230. X
  231. Xif (/a+b?c+/) {print "not ok 15\n";} else {print "ok 15\n";}
  232. X
  233. X$_ = 'aaabccc';
  234. Xif (/a+b?c+/) {print "ok 16\n";} else {print "not ok 16\n";}
  235. Xif (/a*b+c*/) {print "ok 17\n";} else {print "not ok 17\n";}
  236. X
  237. X$_ = 'aaaccc';
  238. Xif (/a*b?c*/) {print "ok 18\n";} else {print "not ok 18\n";}
  239. Xif (/a*b+c*/) {print "not ok 19\n";} else {print "ok 19\n";}
  240. X
  241. X$_ = 'abcdef';
  242. Xif (/bcd|xyz/) {print "ok 20\n";} else {print "not ok 20\n";}
  243. Xif (/xyz|bcd/) {print "ok 21\n";} else {print "not ok 21\n";}
  244. X
  245. Xif (m|bc/*d|) {print "ok 22\n";} else {print "not ok 22\n";}
  246. X
  247. Xif (/^$_$/) {print "ok 23\n";} else {print "not ok 23\n";}
  248. X
  249. X$* = 1;        # test 3 only tested the optimized version--this one is for real
  250. Xif ("ab\ncd\n" =~ /^cd/) {print "ok 24\n";} else {print "not ok 24\n";}
  251. X$* = 0;
  252. X
  253. X$XXX{123} = 123;
  254. X$XXX{234} = 234;
  255. X$XXX{345} = 345;
  256. X
  257. X@XXX = ('ok 25','not ok 25', 'ok 26','not ok 26','not ok 27');
  258. Xwhile ($_ = shift(XXX)) {
  259. X    ?(.*)? && (print $1,"\n");
  260. X    /not/ && reset;
  261. X    /not ok 26/ && reset 'X';
  262. X}
  263. X
  264. Xwhile (($key,$val) = each(XXX)) {
  265. X    print "not ok 27\n";
  266. X    exit;
  267. X}
  268. X
  269. Xprint "ok 27\n";
  270. X
  271. X'cde' =~ /[^ab]*/;
  272. X'xyz' =~ //;
  273. Xif ($& eq 'xyz') {print "ok 28\n";} else {print "not ok 28\n";}
  274. X
  275. X$foo = '[^ab]*';
  276. X'cde' =~ /$foo/;
  277. X'xyz' =~ //;
  278. Xif ($& eq 'xyz') {print "ok 29\n";} else {print "not ok 29\n";}
  279. X
  280. X$foo = '[^ab]*';
  281. X'cde' =~ /$foo/;
  282. X'xyz' =~ /$null/;
  283. Xif ($& eq 'xyz') {print "ok 30\n";} else {print "not ok 30\n";}
  284. X
  285. X$_ = 'abcdefghi';
  286. X/def/;        # optimized up to cmd
  287. Xif ("$`:$&:$'" eq 'abc:def:ghi') {print "ok 31\n";} else {print "not ok 31\n";}
  288. X
  289. X/cde/ + 0;    # optimized only to spat
  290. Xif ("$`:$&:$'" eq 'ab:cde:fghi') {print "ok 32\n";} else {print "not ok 32\n";}
  291. X
  292. X/[d][e][f]/;    # not optimized
  293. Xif ("$`:$&:$'" eq 'abc:def:ghi') {print "ok 33\n";} else {print "not ok 33\n";}
  294. X
  295. X$_ = 'now is the {time for all} good men to come to.';
  296. X/ {([^}]*)}/;
  297. Xif ($1 eq 'time for all') {print "ok 34\n";} else {print "not ok 34 $1\n";}
  298. X
  299. X$_ = 'xxx {3,4}  yyy   zzz';
  300. Xprint /( {3,4})/ ? "ok 35\n" : "not ok 35\n";
  301. Xprint $1 eq '   ' ? "ok 36\n" : "not ok 36\n";
  302. Xprint /( {4,})/ ? "not ok 37\n" : "ok 37\n";
  303. Xprint /( {2,3}.)/ ? "ok 38\n" : "not ok 38\n";
  304. Xprint $1 eq '  y' ? "ok 39\n" : "not ok 39\n";
  305. Xprint /(y{2,3}.)/ ? "ok 40\n" : "not ok 40\n";
  306. Xprint $1 eq 'yyy ' ? "ok 41\n" : "not ok 41\n";
  307. Xprint /x {3,4}/ ? "not ok 42\n" : "ok 42\n";
  308. Xprint /^xxx {3,4}/ ? "not ok 43\n" : "ok 43\n";
  309. !STUFFY!FUNK!
  310. echo Extracting x2p/Makefile.SH
  311. sed >x2p/Makefile.SH <<'!STUFFY!FUNK!' -e 's/X//'
  312. Xcase "$0" in
  313. X*/*) cd `expr X$0 : 'X\(.*\)/'` ;;
  314. Xesac
  315. Xcase $CONFIG in
  316. X'')
  317. X    if test ! -f config.sh; then
  318. X    ln ../config.sh . || \
  319. X    ln ../../config.sh . || \
  320. X    ln ../../../config.sh . || \
  321. X    (echo "Can't find config.sh."; exit 1)
  322. X    fi
  323. X    . ./config.sh
  324. X    ;;
  325. Xesac
  326. Xcase "$mallocsrc" in
  327. X'') ;;
  328. X*) mallocsrc="../$mallocsrc";;
  329. Xesac
  330. Xecho "Extracting x2p/Makefile (with variable substitutions)"
  331. Xcat >Makefile <<!GROK!THIS!
  332. X# $Header: Makefile.SH,v 3.0 89/10/18 15:33:52 lwall Locked $
  333. X#
  334. X# $Log:    Makefile.SH,v $
  335. X# Revision 3.0  89/10/18  15:33:52  lwall
  336. X# 3.0 baseline
  337. X# 
  338. X# Revision 2.0.1.2  88/09/07  17:13:30  lwall
  339. X# patch14: added redirection of stderr to /dev/null
  340. X# 
  341. X# Revision 2.0.1.1  88/07/11  23:13:39  root
  342. X# patch2: now expects more shift/reduce errors
  343. X# 
  344. X# Revision 2.0  88/06/05  00:15:31  root
  345. X# Baseline version 2.0.
  346. X# 
  347. X# 
  348. X
  349. XCC = $cc
  350. Xbin = $bin
  351. Xlib = $lib
  352. Xmansrc = $mansrc
  353. Xmanext = $manext
  354. XCFLAGS = $ccflags $optimize
  355. XLDFLAGS = $ldflags
  356. XSMALL = $small
  357. XLARGE = $large $split
  358. Xmallocsrc = $mallocsrc
  359. Xmallocobj = $mallocobj
  360. X
  361. Xlibs = $libnm -lm $libs
  362. X!GROK!THIS!
  363. X
  364. Xcat >>Makefile <<'!NO!SUBS!'
  365. X
  366. Xpublic = a2p s2p
  367. X
  368. Xprivate = 
  369. X
  370. Xmanpages = a2p.man s2p.man
  371. X
  372. Xutil =
  373. X
  374. Xsh = Makefile.SH makedepend.SH
  375. X
  376. Xh = EXTERN.h INTERN.h config.h handy.h hash.h a2p.h str.h util.h
  377. X
  378. Xc = hash.c $(mallocsrc) str.c util.c walk.c
  379. X
  380. Xobj = hash.o $(mallocobj) str.o util.o walk.o
  381. X
  382. Xlintflags = -phbvxac
  383. X
  384. Xaddedbyconf = Makefile.old bsd eunice filexp loc pdp11 usg v7
  385. X
  386. X# grrr
  387. XSHELL = /bin/sh
  388. X
  389. X.c.o:
  390. X    $(CC) -c $(CFLAGS) $(LARGE) $*.c
  391. X
  392. Xall: $(public) $(private) $(util)
  393. X    touch all
  394. X
  395. Xa2p: $(obj) a2p.o
  396. X    $(CC) $(LARGE) $(LDFLAGS) $(obj) a2p.o $(libs) -o a2p
  397. X
  398. Xa2p.c: a2p.y
  399. X    @ echo Expect 208 shift/reduce conflicts...
  400. X    yacc a2p.y
  401. X    mv y.tab.c a2p.c
  402. X
  403. Xa2p.o: a2p.c a2py.c a2p.h EXTERN.h util.h INTERN.h handy.h ../config.h
  404. X    $(CC) -c $(CFLAGS) $(LARGE) a2p.c
  405. X
  406. Xinstall: a2p s2p
  407. X# won't work with csh
  408. X    export PATH || exit 1
  409. X    - mv $(bin)/a2p $(bin)/a2p.old 2>/dev/null
  410. X    - mv $(bin)/s2p $(bin)/s2p.old 2>/dev/null
  411. X    - if test `pwd` != $(bin); then cp $(public) $(bin); fi
  412. X    cd $(bin); \
  413. Xfor pub in $(public); do \
  414. Xchmod +x `basename $$pub`; \
  415. Xdone
  416. X#    chmod +x makedir
  417. X#    - ./makedir `filexp $(lib)`
  418. X#    - \
  419. X#if test `pwd` != `filexp $(lib)`; then \
  420. X#cp $(private) `filexp $(lib)`; \
  421. X#fi
  422. X#    cd `filexp $(lib)`; \
  423. X#for priv in $(private); do \
  424. X#chmod +x `basename $$priv`; \
  425. X#done
  426. X    - if test `pwd` != $(mansrc); then \
  427. Xfor page in $(manpages); do \
  428. Xcp $$page $(mansrc)/`basename $$page .man`.$(manext); \
  429. Xdone; \
  430. Xfi
  431. X
  432. Xclean:
  433. X    rm -f *.o
  434. X
  435. Xrealclean:
  436. X    rm -f a2p *.orig */*.orig *.o core $(addedbyconf)
  437. X
  438. X# The following lint has practically everything turned on.  Unfortunately,
  439. X# you have to wade through a lot of mumbo jumbo that can't be suppressed.
  440. X# If the source file has a /*NOSTRICT*/ somewhere, ignore the lint message
  441. X# for that spot.
  442. X
  443. Xlint:
  444. X    lint $(lintflags) $(defs) $(c) > a2p.fuzz
  445. X
  446. Xdepend: ../makedepend
  447. X    ../makedepend
  448. X
  449. Xclist:
  450. X    echo $(c) | tr ' ' '\012' >.clist
  451. X
  452. Xhlist:
  453. X    echo $(h) | tr ' ' '\012' >.hlist
  454. X
  455. Xshlist:
  456. X    echo $(sh) | tr ' ' '\012' >.shlist
  457. X
  458. X# AUTOMATICALLY GENERATED MAKE DEPENDENCIES--PUT NOTHING BELOW THIS LINE
  459. X$(obj):
  460. X    @ echo "You haven't done a "'"make depend" yet!'; exit 1
  461. Xmakedepend: makedepend.SH
  462. X    /bin/sh makedepend.SH
  463. X!NO!SUBS!
  464. X$eunicefix Makefile
  465. Xcase `pwd` in
  466. X*SH)
  467. X    $rm -f ../Makefile
  468. X    ln Makefile ../Makefile
  469. X    ;;
  470. Xesac
  471. !STUFFY!FUNK!
  472. echo Extracting t/op.array
  473. sed >t/op.array <<'!STUFFY!FUNK!' -e 's/X//'
  474. X#!./perl
  475. X
  476. X# $Header: op.array,v 3.0 89/10/18 15:26:55 lwall Locked $
  477. X
  478. Xprint "1..30\n";
  479. X
  480. X@ary = (1,2,3,4,5);
  481. Xif (join('',@ary) eq '12345') {print "ok 1\n";} else {print "not ok 1\n";}
  482. X
  483. X$tmp = $ary[$#ary]; --$#ary;
  484. Xif ($tmp == 5) {print "ok 2\n";} else {print "not ok 2\n";}
  485. Xif ($#ary == 3) {print "ok 3\n";} else {print "not ok 3\n";}
  486. Xif (join('',@ary) eq '1234') {print "ok 4\n";} else {print "not ok 4\n";}
  487. X
  488. X$[ = 1;
  489. X@ary = (1,2,3,4,5);
  490. Xif (join('',@ary) eq '12345') {print "ok 5\n";} else {print "not ok 5\n";}
  491. X
  492. X$tmp = $ary[$#ary]; --$#ary;
  493. Xif ($tmp == 5) {print "ok 6\n";} else {print "not ok 6\n";}
  494. Xif ($#ary == 4) {print "ok 7\n";} else {print "not ok 7\n";}
  495. Xif (join('',@ary) eq '1234') {print "ok 8\n";} else {print "not ok 8\n";}
  496. X
  497. Xif ($ary[5] eq '') {print "ok 9\n";} else {print "not ok 9\n";}
  498. X
  499. X$#ary += 1;    # see if we can recover element 5
  500. Xif ($#ary == 5) {print "ok 10\n";} else {print "not ok 10\n";}
  501. Xif ($ary[5] == 5) {print "ok 11\n";} else {print "not ok 11\n";}
  502. X
  503. X$[ = 0;
  504. X@foo = ();
  505. X$r = join(',', $#foo, @foo);
  506. Xif ($r eq "-1") {print "ok 12\n";} else {print "not ok 12 $r\n";}
  507. X$foo[0] = '0';
  508. X$r = join(',', $#foo, @foo);
  509. Xif ($r eq "0,0") {print "ok 13\n";} else {print "not ok 13 $r\n";}
  510. X$foo[2] = '2';
  511. X$r = join(',', $#foo, @foo);
  512. Xif ($r eq "2,0,,2") {print "ok 14\n";} else {print "not ok 14 $r\n";}
  513. X@bar = ();
  514. X$bar[0] = '0';
  515. X$bar[1] = '1';
  516. X$r = join(',', $#bar, @bar);
  517. Xif ($r eq "1,0,1") {print "ok 15\n";} else {print "not ok 15 $r\n";}
  518. X@bar = ();
  519. X$r = join(',', $#bar, @bar);
  520. Xif ($r eq "-1") {print "ok 16\n";} else {print "not ok 16 $r\n";}
  521. X$bar[0] = '0';
  522. X$r = join(',', $#bar, @bar);
  523. Xif ($r eq "0,0") {print "ok 17\n";} else {print "not ok 17 $r\n";}
  524. X$bar[2] = '2';
  525. X$r = join(',', $#bar, @bar);
  526. Xif ($r eq "2,0,,2") {print "ok 18\n";} else {print "not ok 18 $r\n";}
  527. Xreset 'b';
  528. X@bar = ();
  529. X$bar[0] = '0';
  530. X$r = join(',', $#bar, @bar);
  531. Xif ($r eq "0,0") {print "ok 19\n";} else {print "not ok 19 $r\n";}
  532. X$bar[2] = '2';
  533. X$r = join(',', $#bar, @bar);
  534. Xif ($r eq "2,0,,2") {print "ok 20\n";} else {print "not ok 20 $r\n";}
  535. X
  536. X$foo = 'now is the time';
  537. Xif (($F1,$F2,$Etc) = ($foo =~ /^(\S+)\s+(\S+)\s*(.*)/)) {
  538. X    if ($F1 eq 'now' && $F2 eq 'is' && $Etc eq 'the time') {
  539. X    print "ok 21\n";
  540. X    }
  541. X    else {
  542. X    print "not ok 21\n";
  543. X    }
  544. X}
  545. Xelse {
  546. X    print "not ok 21\n";
  547. X}
  548. X
  549. X$foo = 'lskjdf';
  550. Xif ($cnt = (($F1,$F2,$Etc) = ($foo =~ /^(\S+)\s+(\S+)\s*(.*)/))) {
  551. X    print "not ok 22 $cnt $F1:$F2:$Etc\n";
  552. X}
  553. Xelse {
  554. X    print "ok 22\n";
  555. X}
  556. X
  557. X%foo = ('blurfl','dyick','foo','bar','etc.','etc.');
  558. X%bar = %foo;
  559. Xprint $bar{'foo'} eq 'bar' ? "ok 23\n" : "not ok 23\n";
  560. X%bar = ();
  561. Xprint $bar{'foo'} eq '' ? "ok 24\n" : "not ok 24\n";
  562. X(%bar,$a,$b) = (%foo,'how','now');
  563. Xprint $bar{'foo'} eq 'bar' ? "ok 25\n" : "not ok 25\n";
  564. Xprint $bar{'how'} eq 'now' ? "ok 26\n" : "not ok 26\n";
  565. X@bar{keys %foo} = values %foo;
  566. Xprint $bar{'foo'} eq 'bar' ? "ok 27\n" : "not ok 27\n";
  567. Xprint $bar{'how'} eq 'now' ? "ok 28\n" : "not ok 28\n";
  568. X
  569. X@foo = grep(/e/,split(' ','now is the time for all good men to come to'));
  570. Xprint join(' ',@foo) eq 'the time men come' ? "ok 29\n" : "not ok 29\n";
  571. X
  572. X@foo = grep(!/e/,split(' ','now is the time for all good men to come to'));
  573. Xprint join(' ',@foo) eq 'now is for all good to to' ? "ok 30\n" : "not ok 30\n";
  574. !STUFFY!FUNK!
  575. echo Extracting eg/g/gsh
  576. sed >eg/g/gsh <<'!STUFFY!FUNK!' -e 's/X//'
  577. X#!/bin/perl
  578. X
  579. X# $Header: gsh,v 3.0 89/10/18 15:14:36 lwall Locked $
  580. X
  581. X# Do rsh globally--see man page
  582. X
  583. X$SIG{'QUIT'} = 'quit';            # install signal handler for SIGQUIT
  584. X
  585. Xsub getswitches {
  586. X    while ($ARGV[0] =~ /^-/) {        # parse switches
  587. X    $ARGV[0] =~ /^-h/ && ($showhost++,$silent++,shift,next);
  588. X    $ARGV[0] =~ /^-s/ && ($silent++,shift,next);
  589. X    $ARGV[0] =~ /^-d/ && ($dodist++,shift,next);
  590. X    $ARGV[0] =~ /^-n/ && ($n=' -n',shift,next);
  591. X    $ARGV[0] =~ /^-l/ && ($l=' -l ' . $ARGV[1],shift,shift,next);
  592. X    last;
  593. X    }
  594. X}
  595. X
  596. Xdo getswitches();            # get any switches before class
  597. X$systype = shift;            # get name representing set of hosts
  598. Xdo getswitches();            # same switches allowed after class
  599. X
  600. Xif ($dodist) {                # distribute input over all rshes?
  601. X    `cat >/tmp/gsh$$`;            #  get input into a handy place
  602. X    $dist = " </tmp/gsh$$";        #  each rsh takes input from there
  603. X}
  604. X
  605. X$cmd = join(' ',@ARGV);            # remaining args constitute the command
  606. X$cmd =~ s/'/'"'"'/g;            # quote any embedded single quotes
  607. X
  608. X$one_of_these = ":$systype:";        # prepare to expand "macros"
  609. X$one_of_these =~ s/\+/:/g;        # we hope to end up with list of
  610. X$one_of_these =~ s/-/:-/g;        #  colon separated attributes
  611. X
  612. X@ARGV = ();
  613. Xpush(@ARGV,'.grem') if -f '.grem';
  614. Xpush(@ARGV,'.ghosts') if -f '.ghosts';
  615. Xpush(@ARGV,'/etc/ghosts');
  616. X
  617. X$remainder = '';
  618. X
  619. Xline: while (<>) {        # for each line of ghosts
  620. X
  621. X    s/[ \t]*\n//;            # trim trailing whitespace
  622. X    if (!$_ || /^#/) {            # skip blank line or comment
  623. X    next line;
  624. X    }
  625. X
  626. X    if (/^(\w+)=(.+)/) {        # a macro line?
  627. X    $name = $1; $repl = $2;
  628. X    $repl =~ s/\+/:/g;
  629. X    $repl =~ s/-/:-/g;
  630. X    $one_of_these =~ s/:$name:/:$repl:/;    # do expansion in "wanted" list
  631. X    $repl =~ s/:/:-/g;
  632. X    $one_of_these =~ s/:-$name:/:-$repl:/;
  633. X    next line;
  634. X    }
  635. X
  636. X    # we have a normal line
  637. X
  638. X    @attr = split(' ');            # a list of attributes to match against
  639. X                    #   which we put into an array
  640. X    $host = $attr[0];            # the first attribute is the host name
  641. X    if ($showhost) {
  642. X    $showhost = "$host:\t";
  643. X    }
  644. X
  645. X    $wanted = 0;
  646. X    foreach $attr (@attr) {        # iterate over attribute array
  647. X    $wanted++ if index($one_of_these,":$attr:") >= 0;
  648. X    $wanted = -9999 if index($one_of_these,":-$attr:") >= 0;
  649. X    }
  650. X    if ($wanted > 0) {
  651. X    print "rsh $host$l$n '$cmd'\n" unless $silent;
  652. X    $SIG{'INT'} = 'DEFAULT';
  653. X    if (open(pipe,"rsh $host$l$n '$cmd'$dist 2>&1|")) {    # start an rsh
  654. X        $SIG{'INT'} = 'cont';
  655. X        for ($iter=0; <pipe>; $iter++) {
  656. X        unless ($iter) {
  657. X            $remainder .= "$host+"
  658. X            if /Connection timed out|Permission denied/;
  659. X        }
  660. X        print $showhost,$_;
  661. X        }
  662. X        close(pipe);
  663. X    } else {
  664. X        print "(Can't execute rsh: $!)\n";
  665. X        $SIG{'INT'} = 'cont';
  666. X    }
  667. X    }
  668. X}
  669. X
  670. Xunlink "/tmp/gsh$$" if $dodist;
  671. X
  672. Xif ($remainder) {
  673. X    chop($remainder);
  674. X    open(grem,">.grem") || (printf stderr "Can't make a .grem file: $!\n");
  675. X    print grem 'rem=', $remainder, "\n";
  676. X    close(grem);
  677. X    print 'rem=', $remainder, "\n";
  678. X}
  679. X
  680. X# here are a couple of subroutines that serve as signal handlers
  681. X
  682. Xsub cont {
  683. X    print "\rContinuing...\n";
  684. X    $remainder .= "$host+";
  685. X}
  686. X
  687. Xsub quit {
  688. X    $| = 1;
  689. X    print "\r";
  690. X    $SIG{'INT'} = '';
  691. X    kill 2, $$;
  692. X}
  693. !STUFFY!FUNK!
  694. echo Extracting t/re_tests
  695. sed >t/re_tests <<'!STUFFY!FUNK!' -e 's/X//'
  696. Xabc    abc    y    $&    abc
  697. Xabc    xbc    n    -    -
  698. Xabc    axc    n    -    -
  699. Xabc    abx    n    -    -
  700. Xabc    xabcy    y    $&    abc
  701. Xabc    ababc    y    $&    abc
  702. Xab*c    abc    y    $&    abc
  703. Xab*bc    abc    y    $&    abc
  704. Xab*bc    abbc    y    $&    abbc
  705. Xab*bc    abbbbc    y    $&    abbbbc
  706. Xab{0,}bc    abbbbc    y    $&    abbbbc
  707. Xab+bc    abbc    y    $&    abbc
  708. Xab+bc    abc    n    -    -
  709. Xab+bc    abq    n    -    -
  710. Xab{1,}bc    abq    n    -    -
  711. Xab+bc    abbbbc    y    $&    abbbbc
  712. Xab{1,}bc    abbbbc    y    $&    abbbbc
  713. Xab{1,3}bc    abbbbc    y    $&    abbbbc
  714. Xab{3,4}bc    abbbbc    y    $&    abbbbc
  715. Xab{4,5}bc    abbbbc    n    -    -
  716. Xab?bc    abbc    y    $&    abbc
  717. Xab?bc    abc    y    $&    abc
  718. Xab{0,1}bc    abc    y    $&    abc
  719. Xab?bc    abbbbc    n    -    -
  720. Xab?c    abc    y    $&    abc
  721. Xab{0,1}c    abc    y    $&    abc
  722. X^abc$    abc    y    $&    abc
  723. X^abc$    abcc    n    -    -
  724. X^abc    abcc    y    $&    abc
  725. X^abc$    aabc    n    -    -
  726. Xabc$    aabc    y    $&    abc
  727. X^    abc    y    $&    
  728. X$    abc    y    $&    
  729. Xa.c    abc    y    $&    abc
  730. Xa.c    axc    y    $&    axc
  731. Xa.*c    axyzc    y    $&    axyzc
  732. Xa.*c    axyzd    n    -    -
  733. Xa[bc]d    abc    n    -    -
  734. Xa[bc]d    abd    y    $&    abd
  735. Xa[b-d]e    abd    n    -    -
  736. Xa[b-d]e    ace    y    $&    ace
  737. Xa[b-d]    aac    y    $&    ac
  738. Xa[-b]    a-    y    $&    a-
  739. Xa[b-]    a-    y    $&    a-
  740. Xa[b-a]    -    c    -    -
  741. Xa[]b    -    c    -    -
  742. Xa[    -    c    -    -
  743. Xa]    a]    y    $&    a]
  744. Xa[]]b    a]b    y    $&    a]b
  745. Xa[^bc]d    aed    y    $&    aed
  746. Xa[^bc]d    abd    n    -    -
  747. Xa[^-b]c    adc    y    $&    adc
  748. Xa[^-b]c    a-c    n    -    -
  749. Xa[^]b]c    a]c    n    -    -
  750. Xa[^]b]c    adc    y    $&    adc
  751. Xab|cd    abc    y    $&    ab
  752. Xab|cd    abcd    y    $&    ab
  753. X()ef    def    y    $&-$1    ef-
  754. X()*    -    c    -    -
  755. X*a    -    c    -    -
  756. X^*    -    c    -    -
  757. X$*    -    c    -    -
  758. X(*)b    -    c    -    -
  759. X$b    b    n    -    -
  760. Xa\    -    c    -    -
  761. Xa\(b    a(b    y    $&-$1    a(b-
  762. Xa\(*b    ab    y    $&    ab
  763. Xa\(*b    a((b    y    $&    a((b
  764. Xa\\b    a\b    y    $&    a\b
  765. Xabc)    -    c    -    -
  766. X(abc    -    c    -    -
  767. X((a))    abc    y    $&-$1-$2    a-a-a
  768. X(a)b(c)    abc    y    $&-$1-$2    abc-a-c
  769. Xa+b+c    aabbabc    y    $&    abc
  770. Xa{1,}b{1,}c    aabbabc    y    $&    abc
  771. Xa**    -    c    -    -
  772. Xa*?    -    c    -    -
  773. X(a*)*    -    c    -    -
  774. X(a*)+    -    c    -    -
  775. X(a|)*    -    c    -    -
  776. X(a*|b)*    -    c    -    -
  777. X(a+|b)*    ab    y    $&-$1    ab-b
  778. X(a+|b){0,}    ab    y    $&-$1    ab-b
  779. X(a+|b)+    ab    y    $&-$1    ab-b
  780. X(a+|b){1,}    ab    y    $&-$1    ab-b
  781. X(a+|b)?    ab    y    $&-$1    a-a
  782. X(a+|b){0,1}    ab    y    $&-$1    a-a
  783. X(^)*    -    c    -    -
  784. X(ab|)*    -    c    -    -
  785. X)(    -    c    -    -
  786. X[^ab]*    cde    y    $&    cde
  787. Xabc        n    -    -
  788. Xa*        y    $&    
  789. X([abc])*d    abbbcd    y    $&-$1    abbbcd-c
  790. X([abc])*bcd    abcd    y    $&-$1    abcd-a
  791. Xa|b|c|d|e    e    y    $&    e
  792. X(a|b|c|d|e)f    ef    y    $&-$1    ef-e
  793. X((a*|b))*    -    c    -    -
  794. Xabcd*efg    abcdefg    y    $&    abcdefg
  795. Xab*    xabyabbbz    y    $&    ab
  796. Xab*    xayabbbz    y    $&    a
  797. X(ab|cd)e    abcde    y    $&-$1    cde-cd
  798. X[abhgefdc]ij    hij    y    $&    hij
  799. X^(ab|cd)e    abcde    n    x$1y    xy
  800. X(abc|)ef    abcdef    y    $&-$1    ef-
  801. X(a|b)c*d    abcd    y    $&-$1    bcd-b
  802. X(ab|ab*)bc    abc    y    $&-$1    abc-a
  803. Xa([bc]*)c*    abc    y    $&-$1    abc-bc
  804. Xa([bc]*)(c*d)    abcd    y    $&-$1-$2    abcd-bc-d
  805. Xa([bc]+)(c*d)    abcd    y    $&-$1-$2    abcd-bc-d
  806. Xa([bc]*)(c+d)    abcd    y    $&-$1-$2    abcd-b-cd
  807. Xa[bcd]*dcdcde    adcdcde    y    $&    adcdcde
  808. Xa[bcd]+dcdcde    adcdcde    n    -    -
  809. X(ab|a)b*c    abc    y    $&-$1    abc-ab
  810. X((a)(b)c)(d)    abcd    y    $1-$2-$3-$4    abc-a-b-d
  811. X[a-zA-Z_][a-zA-Z0-9_]*    alpha    y    $&    alpha
  812. X^a(bc+|b[eh])g|.h$    abh    y    $&-$1    bh-
  813. X(bc+d$|ef*g.|h?i(j|k))    effgz    y    $&-$1-$2    effgz-effgz-
  814. X(bc+d$|ef*g.|h?i(j|k))    ij    y    $&-$1-$2    ij-ij-j
  815. X(bc+d$|ef*g.|h?i(j|k))    effg    n    -    -
  816. X(bc+d$|ef*g.|h?i(j|k))    bcdd    n    -    -
  817. X(bc+d$|ef*g.|h?i(j|k))    reffgz    y    $&-$1-$2    effgz-effgz-
  818. X((((((((((a))))))))))    -    c    -    -
  819. X(((((((((a)))))))))    a    y    $&    a
  820. Xmultiple words of text    uh-uh    n    -    -
  821. Xmultiple words    multiple words, yeah    y    $&    multiple words
  822. X(.*)c(.*)    abcde    y    $&-$1-$2    abcde-ab-de
  823. X\((.*), (.*)\)    (a, b)    y    ($2, $1)    (b, a)
  824. X[k]    ab    n    -    -
  825. Xabcd    abcd    y    $&-\$&-\\$&    abcd-$&-\abcd
  826. Xa(bc)d    abcd    y    $1-\$1-\\$1    bc-$1-\bc
  827. Xa[-]?c    ac    y    $&    ac
  828. X(abc)\1    abcabc    y    $1    abc
  829. X([a-c]*)\1    abcabc    y    $1    abc
  830. !STUFFY!FUNK!
  831. echo Extracting t/io.fs
  832. sed >t/io.fs <<'!STUFFY!FUNK!' -e 's/X//'
  833. X#!./perl
  834. X
  835. X# $Header: io.fs,v 3.0 89/10/18 15:26:20 lwall Locked $
  836. X
  837. Xprint "1..22\n";
  838. X
  839. X$wd = `pwd`;
  840. Xchop($wd);
  841. X
  842. X`rm -f tmp 2>/dev/null; mkdir tmp 2>/dev/null`;
  843. Xchdir './tmp';
  844. X`/bin/rm -rf a b c x`;
  845. X
  846. Xumask(022);
  847. X
  848. Xif (umask(0) == 022) {print "ok 1\n";} else {print "not ok 1\n";}
  849. Xopen(fh,'>x') || die "Can't create x";
  850. Xclose(fh);
  851. Xopen(fh,'>a') || die "Can't create a";
  852. Xclose(fh);
  853. X
  854. Xif (link('a','b')) {print "ok 2\n";} else {print "not ok 2\n";}
  855. X
  856. Xif (link('b','c')) {print "ok 3\n";} else {print "not ok 3\n";}
  857. X
  858. X($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
  859. X    $blksize,$blocks) = stat('c');
  860. X
  861. Xif ($nlink == 3) {print "ok 4\n";} else {print "not ok 4\n";}
  862. Xif (($mode & 0777) == 0666) {print "ok 5\n";} else {print "not ok 5\n";}
  863. X
  864. Xif ((chmod 0777,'a') == 1) {print "ok 6\n";} else {print "not ok 6\n";}
  865. X
  866. X($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
  867. X    $blksize,$blocks) = stat('c');
  868. Xif (($mode & 0777) == 0777) {print "ok 7\n";} else {print "not ok 7\n";}
  869. X
  870. Xif ((chmod 0700,'c','x') == 2) {print "ok 8\n";} else {print "not ok 8\n";}
  871. X
  872. X($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
  873. X    $blksize,$blocks) = stat('c');
  874. Xif (($mode & 0777) == 0700) {print "ok 9\n";} else {print "not ok 9\n";}
  875. X($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
  876. X    $blksize,$blocks) = stat('x');
  877. Xif (($mode & 0777) == 0700) {print "ok 10\n";} else {print "not ok 10\n";}
  878. X
  879. Xif ((unlink 'b','x') == 2) {print "ok 11\n";} else {print "not ok 11\n";}
  880. X($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
  881. X    $blksize,$blocks) = stat('b');
  882. Xif ($ino == 0) {print "ok 12\n";} else {print "not ok 12\n";}
  883. X($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
  884. X    $blksize,$blocks) = stat('x');
  885. Xif ($ino == 0) {print "ok 13\n";} else {print "not ok 13\n";}
  886. X
  887. Xif (rename('a','b')) {print "ok 14\n";} else {print "not ok 14\n";}
  888. X($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
  889. X    $blksize,$blocks) = stat('a');
  890. Xif ($ino == 0) {print "ok 15\n";} else {print "not ok 15\n";}
  891. X$foo = (utime 500000000,500000001,'b');
  892. Xif ($foo == 1) {print "ok 16\n";} else {print "not ok 16 $foo\n";}
  893. X($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
  894. X    $blksize,$blocks) = stat('b');
  895. Xif ($ino) {print "ok 17\n";} else {print "not ok 17\n";}
  896. Xif ($atime == 500000000 && $mtime == 500000001)
  897. X    {print "ok 18\n";} else {print "not ok 18 $atime $mtime\n";}
  898. X
  899. Xif ((unlink 'b') == 1) {print "ok 19\n";} else {print "not ok 19\n";}
  900. X($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
  901. X    $blksize,$blocks) = stat('b');
  902. Xif ($ino == 0) {print "ok 20\n";} else {print "not ok 20\n";}
  903. Xunlink 'c';
  904. X
  905. Xchdir $wd || die "Can't cd back to $wd";
  906. X
  907. Xunlink 'c';
  908. Xif (`ls -l perl 2>/dev/null` =~ /^l.*->/) {  # we have symbolic links
  909. X    if (symlink("TEST","c")) {print "ok 21\n";} else {print "not ok 21\n";}
  910. X    $foo = `grep perl c`;
  911. X    if ($foo) {print "ok 22\n";} else {print "not ok 22\n";}
  912. X}
  913. Xelse {
  914. X    print "ok 21\nok 22\n";
  915. X}
  916. !STUFFY!FUNK!
  917. echo Extracting t/comp.cmdopt
  918. sed >t/comp.cmdopt <<'!STUFFY!FUNK!' -e 's/X//'
  919. X#!./perl
  920. X
  921. X# $Header: comp.cmdopt,v 3.0 89/10/18 15:25:13 lwall Locked $
  922. X
  923. Xprint "1..40\n";
  924. X
  925. X# test the optimization of constants
  926. X
  927. Xif (1) { print "ok 1\n";} else { print "not ok 1\n";}
  928. Xunless (0) { print "ok 2\n";} else { print "not ok 2\n";}
  929. X
  930. Xif (0) { print "not ok 3\n";} else { print "ok 3\n";}
  931. Xunless (1) { print "not ok 4\n";} else { print "ok 4\n";}
  932. X
  933. Xunless (!1) { print "ok 5\n";} else { print "not ok 5\n";}
  934. Xif (!0) { print "ok 6\n";} else { print "not ok 6\n";}
  935. X
  936. Xunless (!0) { print "not ok 7\n";} else { print "ok 7\n";}
  937. Xif (!1) { print "not ok 8\n";} else { print "ok 8\n";}
  938. X
  939. X$x = 1;
  940. Xif (1 && $x) { print "ok 9\n";} else { print "not ok 9\n";}
  941. Xif (0 && $x) { print "not ok 10\n";} else { print "ok 10\n";}
  942. X$x = '';
  943. Xif (1 && $x) { print "not ok 11\n";} else { print "ok 11\n";}
  944. Xif (0 && $x) { print "not ok 12\n";} else { print "ok 12\n";}
  945. X
  946. X$x = 1;
  947. Xif (1 || $x) { print "ok 13\n";} else { print "not ok 13\n";}
  948. Xif (0 || $x) { print "ok 14\n";} else { print "not ok 14\n";}
  949. X$x = '';
  950. Xif (1 || $x) { print "ok 15\n";} else { print "not ok 15\n";}
  951. Xif (0 || $x) { print "not ok 16\n";} else { print "ok 16\n";}
  952. X
  953. X
  954. X# test the optimization of registers
  955. X
  956. X$x = 1;
  957. Xif ($x) { print "ok 17\n";} else { print "not ok 17\n";}
  958. Xunless ($x) { print "not ok 18\n";} else { print "ok 18\n";}
  959. X
  960. X$x = '';
  961. Xif ($x) { print "not ok 19\n";} else { print "ok 19\n";}
  962. Xunless ($x) { print "ok 20\n";} else { print "not ok 20\n";}
  963. X
  964. X# test optimization of string operations
  965. X
  966. X$a = 'a';
  967. Xif ($a eq 'a') { print "ok 21\n";} else { print "not ok 21\n";}
  968. Xif ($a ne 'a') { print "not ok 22\n";} else { print "ok 22\n";}
  969. X
  970. Xif ($a =~ /a/) { print "ok 23\n";} else { print "not ok 23\n";}
  971. Xif ($a !~ /a/) { print "not ok 24\n";} else { print "ok 24\n";}
  972. X# test interaction of logicals and other operations
  973. X
  974. X$a = 'a';
  975. X$x = 1;
  976. Xif ($a eq 'a' && $x) { print "ok 25\n";} else { print "not ok 25\n";}
  977. Xif ($a ne 'a' && $x) { print "not ok 26\n";} else { print "ok 26\n";}
  978. X$x = '';
  979. Xif ($a eq 'a' && $x) { print "not ok 27\n";} else { print "ok 27\n";}
  980. Xif ($a ne 'a' && $x) { print "not ok 28\n";} else { print "ok 28\n";}
  981. X
  982. X$x = 1;
  983. Xif ($a eq 'a' || $x) { print "ok 29\n";} else { print "not ok 29\n";}
  984. Xif ($a ne 'a' || $x) { print "ok 30\n";} else { print "not ok 30\n";}
  985. X$x = '';
  986. Xif ($a eq 'a' || $x) { print "ok 31\n";} else { print "not ok 31\n";}
  987. Xif ($a ne 'a' || $x) { print "not ok 32\n";} else { print "ok 32\n";}
  988. X
  989. X$x = 1;
  990. Xif ($a =~ /a/ && $x) { print "ok 33\n";} else { print "not ok 33\n";}
  991. Xif ($a !~ /a/ && $x) { print "not ok 34\n";} else { print "ok 34\n";}
  992. X$x = '';
  993. Xif ($a =~ /a/ && $x) { print "not ok 35\n";} else { print "ok 35\n";}
  994. X    if ($a !~ /a/ && $x) { print "not ok 36\n";} else { print "ok 36\n";}
  995. X
  996. X$x = 1;
  997. Xif ($a =~ /a/ || $x) { print "ok 37\n";} else { print "not ok 37\n";}
  998. Xif ($a !~ /a/ || $x) { print "ok 38\n";} else { print "not ok 38\n";}
  999. X$x = '';
  1000. Xif ($a =~ /a/ || $x) { print "ok 39\n";} else { print "not ok 39\n";}
  1001. Xif ($a !~ /a/ || $x) { print "not ok 40\n";} else { print "ok 40\n";}
  1002. !STUFFY!FUNK!
  1003. echo Extracting eg/muck
  1004. sed >eg/muck <<'!STUFFY!FUNK!' -e 's/X//'
  1005. X#!../perl
  1006. X
  1007. X$M = '-M';
  1008. X$M = '-m' if -d '/usr/uts' && -f '/etc/master';
  1009. X
  1010. Xdo 'getopt.pl';
  1011. Xdo Getopt('f');
  1012. X
  1013. Xif ($opt_f) {
  1014. X    $makefile = $opt_f;
  1015. X}
  1016. Xelsif (-f 'makefile') {
  1017. X    $makefile = 'makefile';
  1018. X}
  1019. Xelsif (-f 'Makefile') {
  1020. X    $makefile = 'Makefile';
  1021. X}
  1022. Xelse {
  1023. X    die "No makefile\n";
  1024. X}
  1025. X
  1026. X$MF = 'mf00';
  1027. X
  1028. Xwhile(($key,$val) = each(ENV)) {
  1029. X    $mac{$key} = $val;
  1030. X}
  1031. X
  1032. Xdo scan($makefile);
  1033. X
  1034. X$co = $action{'.c.o'};
  1035. X$co = ' ' unless $co;
  1036. X
  1037. X$missing = "Missing dependencies:\n";
  1038. Xforeach $key (sort keys(o)) {
  1039. X    if ($oc{$key}) {
  1040. X    $src = $oc{$key};
  1041. X    $action = $action{$key};
  1042. X    }
  1043. X    else {
  1044. X    $action = '';
  1045. X    }
  1046. X    if (!$action) {
  1047. X    if ($co && ($c = $key) =~ s/\.o$/.c/ && -f $c) {
  1048. X        $src = $c;
  1049. X        $action = $co;
  1050. X    }
  1051. X    else {
  1052. X        print "No source found for $key $c\n";
  1053. X        next;
  1054. X    }
  1055. X    }
  1056. X    $I = '';
  1057. X    $D = '';
  1058. X    $I .= $1 while $action =~ s/(-I\S+\s*)//;
  1059. X    $D .= $1 . ' ' while $action =~ s/(-D\w+)//;
  1060. X    if ($opt_v) {
  1061. X    $cmd = "Checking $key: cc $M $D $I $src";
  1062. X    $cmd =~ s/\s\s+/ /g;
  1063. X    print stderr $cmd,"\n";
  1064. X    }
  1065. X    open(CPP,"cc $M $D $I $src|") || die "Can't run C preprocessor: $!";
  1066. X    while (<CPP>) {
  1067. X    ($name,$dep) = split;
  1068. X    $dep =~ s|^\./||;
  1069. X    (print $missing,"$key: $dep\n"),($missing='')
  1070. X        unless ($dep{"$key: $dep"} += 2) > 2;
  1071. X    }
  1072. X}
  1073. X
  1074. X$extra = "\nExtraneous dependencies:\n";
  1075. Xforeach $key (sort keys(dep)) {
  1076. X    if ($key =~ /\.o: .*\.h$/ && $dep{$key} == 1) {
  1077. X    print $extra,$key,"\n";
  1078. X    $extra = '';
  1079. X    }
  1080. X}
  1081. X
  1082. Xsub scan {
  1083. X    local($makefile) = @_;
  1084. X    local($MF) = $MF;
  1085. X    print stderr "Analyzing $makefile.\n" if $opt_v;
  1086. X    $MF++;
  1087. X    open($MF,$makefile) || die "Can't open $makefile: $!";
  1088. X    while (<$MF>) {
  1089. X    chop;
  1090. X    chop($_ = $_ . <$MF>) while s/\\$//;
  1091. X    next if /^#/;
  1092. X    next if /^$/;
  1093. X    s/\$\((\w+):([^=)]*)=([^)]*)\)/do subst("$1","$2","$3")/eg;
  1094. X    s/\$\((\w+)\)/$mac{$1}/eg;
  1095. X    $mac{$1} = $2, next if /^(\w+)\s*=\s*(.*)/;
  1096. X    if (/^include\s+(.*)/) {
  1097. X        do scan($1);
  1098. X        print stderr "Continuing $makefile.\n" if $opt_v;
  1099. X        next;
  1100. X    }
  1101. X    if (/^([^:]+):\s*(.*)/) {
  1102. X        $left = $1;
  1103. X        $right = $2;
  1104. X        if ($right =~ /^([^;]*);(.*)/) {
  1105. X        $right = $1;
  1106. X        $action = $2;
  1107. X        }
  1108. X        else {
  1109. X        $action = '';
  1110. X        }
  1111. X        while (<$MF>) {
  1112. X        last unless /^\t/;
  1113. X        chop;
  1114. X        chop($_ = $_ . <$MF>) while s/\\$//;
  1115. X        next if /^#/;
  1116. X        last if /^$/;
  1117. X        s/\$\((\w+):([^=)]*)=([^)]*)\)/do subst("$1","$2","$3")/eg;
  1118. X        s/\$\((\w+)\)/$mac{$1}/eg;
  1119. X        $action .= $_;
  1120. X        }
  1121. X        foreach $targ (split(' ',$left)) {
  1122. X        $targ =~ s|^\./||;
  1123. X        foreach $src (split(' ',$right)) {
  1124. X            $src =~ s|^\./||;
  1125. X            $deplist{$targ} .= ' ' . $src;
  1126. X            $dep{"$targ: $src"} = 1;
  1127. X            $o{$src} = 1 if $src =~ /\.o$/;
  1128. X            $oc{$targ} = $src if $targ =~ /\.o$/ && $src =~ /\.[yc]$/;
  1129. X        }
  1130. X        $action{$targ} .= $action;
  1131. X        }
  1132. X        redo if $_;
  1133. X    }
  1134. X    }
  1135. X    close($MF);
  1136. X}
  1137. X
  1138. Xsub subst {
  1139. X    local($foo,$from,$to) = @_;
  1140. X    $foo = $mac{$foo};
  1141. X    $from =~ s/\./[.]/;
  1142. X    y/a/a/;
  1143. X    $foo =~ s/\b$from\b/$to/g;
  1144. X    $foo;
  1145. X}
  1146. !STUFFY!FUNK!
  1147. echo Extracting handy.h
  1148. sed >handy.h <<'!STUFFY!FUNK!' -e 's/X//'
  1149. X/* $Header: handy.h,v 3.0 89/10/18 15:18:24 lwall Locked $
  1150. X *
  1151. X *    Copyright (c) 1989, Larry Wall
  1152. X *
  1153. X *    You may distribute under the terms of the GNU General Public License
  1154. X *    as specified in the README file that comes with the perl 3.0 kit.
  1155. X *
  1156. X * $Log:    handy.h,v $
  1157. X * Revision 3.0  89/10/18  15:18:24  lwall
  1158. X * 3.0 baseline
  1159. X * 
  1160. X */
  1161. X
  1162. X#ifdef NULL
  1163. X#undef NULL
  1164. X#endif
  1165. X#ifndef I286
  1166. X#  define NULL 0
  1167. X#else
  1168. X#  define NULL 0L
  1169. X#endif
  1170. X#define Null(type) ((type)NULL)
  1171. X#define Nullch Null(char*)
  1172. X#define Nullfp Null(FILE*)
  1173. X
  1174. X#ifdef UTS
  1175. X#define bool int
  1176. X#else
  1177. X#define bool char
  1178. X#endif
  1179. X#define TRUE (1)
  1180. X#define FALSE (0)
  1181. X
  1182. X#define Ctl(ch) (ch & 037)
  1183. X
  1184. X#define strNE(s1,s2) (strcmp(s1,s2))
  1185. X#define strEQ(s1,s2) (!strcmp(s1,s2))
  1186. X#define strLT(s1,s2) (strcmp(s1,s2) < 0)
  1187. X#define strLE(s1,s2) (strcmp(s1,s2) <= 0)
  1188. X#define strGT(s1,s2) (strcmp(s1,s2) > 0)
  1189. X#define strGE(s1,s2) (strcmp(s1,s2) >= 0)
  1190. X#define strnNE(s1,s2,l) (strncmp(s1,s2,l))
  1191. X#define strnEQ(s1,s2,l) (!strncmp(s1,s2,l))
  1192. X
  1193. X#define MEM_SIZE unsigned int
  1194. X
  1195. X/* Line numbers are unsigned, 16 bits. */
  1196. Xtypedef unsigned short line_t;
  1197. X#ifdef lint
  1198. X#define NOLINE ((line_t)0)
  1199. X#else
  1200. X#define NOLINE ((line_t) 65535)
  1201. X#endif
  1202. X
  1203. X#ifndef lint
  1204. X#ifndef LEAKTEST
  1205. Xchar *safemalloc();
  1206. Xchar *saferealloc();
  1207. Xvoid safefree();
  1208. X#define New(x,v,n,t)  (v = (t*)safemalloc((MEM_SIZE)((n) * sizeof(t))))
  1209. X#define Newc(x,v,n,t,c)  (v = (c*)safemalloc((MEM_SIZE)((n) * sizeof(t))))
  1210. X#define Newz(x,v,n,t) (v = (t*)safemalloc((MEM_SIZE)((n) * sizeof(t)))), \
  1211. X    bzero((char*)(v), (n) * sizeof(t))
  1212. X#define Renew(v,n,t) (v = (t*)saferealloc((char*)(v),(MEM_SIZE)((n)*sizeof(t))))
  1213. X#define Renewc(v,n,t,c) (v = (c*)saferealloc((char*)(v),(MEM_SIZE)((n)*sizeof(t))))
  1214. X#define Safefree(d) safefree((char*)d)
  1215. X#define Str_new(x,len) str_new(len)
  1216. X#else /* LEAKTEST */
  1217. Xchar *safexmalloc();
  1218. Xchar *safexrealloc();
  1219. Xvoid safexfree();
  1220. X#define New(x,v,n,t)  (v = (t*)safexmalloc(x,(MEM_SIZE)((n) * sizeof(t))))
  1221. X#define Newc(x,v,n,t,c)  (v = (c*)safexmalloc(x,(MEM_SIZE)((n) * sizeof(t))))
  1222. X#define Newz(x,v,n,t) (v = (t*)safexmalloc(x,(MEM_SIZE)((n) * sizeof(t)))), \
  1223. X    bzero((char*)(v), (n) * sizeof(t))
  1224. X#define Renew(v,n,t) (v = (t*)safexrealloc((char*)(v),(MEM_SIZE)((n)*sizeof(t))))
  1225. X#define Renewc(v,n,t,c) (v = (c*)safexrealloc((char*)(v),(MEM_SIZE)((n)*sizeof(t))))
  1226. X#define Safefree(d) safexfree((char*)d)
  1227. X#define Str_new(x,len) str_new(x,len)
  1228. X#define MAXXCOUNT 1200
  1229. Xlong xcount[MAXXCOUNT];
  1230. Xlong lastxcount[MAXXCOUNT];
  1231. X#endif /* LEAKTEST */
  1232. X#define Copy(s,d,n,t) (void)bcopy((char*)(s),(char*)(d), (n) * sizeof(t))
  1233. X#define Zero(d,n,t) (void)bzero((char*)(d), (n) * sizeof(t))
  1234. X#else /* lint */
  1235. X#define New(x,v,n,s) (v = Null(s *))
  1236. X#define Newc(x,v,n,s,c) (v = Null(s *))
  1237. X#define Newz(x,v,n,s) (v = Null(s *))
  1238. X#define Renew(v,n,s) (v = Null(s *))
  1239. X#define Copy(s,d,n,t)
  1240. X#define Zero(d,n,t)
  1241. X#define Safefree(d) d = d
  1242. X#endif /* lint */
  1243. !STUFFY!FUNK!
  1244. echo Extracting eg/g/gcp
  1245. sed >eg/g/gcp <<'!STUFFY!FUNK!' -e 's/X//'
  1246. X#!/usr/bin/perl
  1247. X
  1248. X# $Header: gcp,v 3.0 89/10/18 15:13:59 lwall Locked $
  1249. X
  1250. X# Here is a script to do global rcps.  See man page.
  1251. X
  1252. X$#ARGV >= 1 || die "Not enough arguments.\n";
  1253. X
  1254. Xif ($ARGV[0] eq '-r') {
  1255. X    $rcp = 'rcp -r';
  1256. X    shift;
  1257. X} else {
  1258. X    $rcp = 'rcp';
  1259. X}
  1260. X$args = $rcp;
  1261. X$dest = $ARGV[$#ARGV];
  1262. X
  1263. X$SIG{'QUIT'} = 'CLEANUP';
  1264. X$SIG{'INT'} = 'CONT';
  1265. X
  1266. Xwhile ($arg = shift) {
  1267. X    if ($arg =~ /^([-a-zA-Z0-9_+]+):/) {
  1268. X    if ($systype && $systype ne $1) {
  1269. X        die "Can't mix system type specifers ($systype vs $1).\n";
  1270. X    }
  1271. X    $#ARGV < 0 || $arg !~ /:$/ || die "No source file specified.\n";
  1272. X    $systype = $1;
  1273. X    $args .= " $arg";
  1274. X    } else {
  1275. X    if ($#ARGV >= 0) {
  1276. X        if ($arg =~ /^[\/~]/) {
  1277. X        $arg =~ /^(.*)\// && ($dir = $1);
  1278. X        } else {
  1279. X        if (!$pwd) {
  1280. X            chop($pwd = `pwd`);
  1281. X        }
  1282. X        $dir = $pwd;
  1283. X        }
  1284. X    }
  1285. X    if ($olddir && $dir ne $olddir && $dest =~ /:$/) {
  1286. X        $args .= " $dest$olddir; $rcp";
  1287. X    }
  1288. X    $olddir = $dir;
  1289. X    $args .= " $arg";
  1290. X    }
  1291. X}
  1292. X
  1293. Xdie "No system type specified.\n" unless $systype;
  1294. X
  1295. X$args =~ s/:$/:$olddir/;
  1296. X
  1297. Xchop($thishost = `hostname`);
  1298. X
  1299. X$one_of_these = ":$systype:";
  1300. Xif ($systype =~ s/\+/[+]/g) {
  1301. X    $one_of_these =~ s/\+/:/g;
  1302. X}
  1303. X$one_of_these =~ s/-/:-/g;
  1304. X
  1305. X@ARGV = ();
  1306. Xpush(@ARGV,'.grem') if -f '.grem';
  1307. Xpush(@ARGV,'.ghosts') if -f '.ghosts';
  1308. Xpush(@ARGV,'/etc/ghosts');
  1309. X
  1310. X$remainder = '';
  1311. X
  1312. Xline: while (<>) {
  1313. X    s/[ \t]*\n//;
  1314. X    if (!$_ || /^#/) {
  1315. X    next line;
  1316. X    }
  1317. X    if (/^([a-zA-Z_0-9]+)=(.+)/) {
  1318. X    $name = $1; $repl = $2;
  1319. X    $repl =~ s/\+/:/g;
  1320. X    $repl =~ s/-/:-/g;
  1321. X    $one_of_these =~ s/:$name:/:$repl:/;
  1322. X    $repl =~ s/:/:-/g;
  1323. X    $one_of_these =~ s/:-$name:/:-$repl:/g;
  1324. X    next line;
  1325. X    }
  1326. X    @gh = split(' ');
  1327. X    $host = $gh[0];
  1328. X  next line if $host eq $thishost;    # should handle aliases too
  1329. X    $wanted = 0;
  1330. X    foreach $class (@gh) {
  1331. X    $wanted++ if index($one_of_these,":$class:") >= 0;
  1332. X    $wanted = -9999 if index($one_of_these,":-$class:") >= 0;
  1333. X    }
  1334. X    if ($wanted > 0) {
  1335. X    ($cmd = $args) =~ s/[ \t]$systype:/ $host:/g;
  1336. X    print "$cmd\n";
  1337. X    $result = `$cmd 2>&1`;
  1338. X    $remainder .= "$host+" if
  1339. X        $result =~ /Connection timed out|Permission denied/;
  1340. X    print $result;
  1341. X    }
  1342. X}
  1343. X
  1344. Xif ($remainder) {
  1345. X    chop($remainder);
  1346. X    open(grem,">.grem") || (printf stderr "Can't create .grem: $!\n");
  1347. X    print grem 'rem=', $remainder, "\n";
  1348. X    close(grem);
  1349. X    print 'rem=', $remainder, "\n";
  1350. X}
  1351. X
  1352. Xsub CLEANUP {
  1353. X    exit;
  1354. X}
  1355. X
  1356. Xsub CONT {
  1357. X    print "Continuing...\n";    # Just ignore the signal that kills rcp
  1358. X    $remainder .= "$host+";
  1359. X}
  1360. !STUFFY!FUNK!
  1361. echo Extracting t/cmd.while
  1362. sed >t/cmd.while <<'!STUFFY!FUNK!' -e 's/X//'
  1363. X#!./perl
  1364. X
  1365. X# $Header: cmd.while,v 3.0 89/10/18 15:25:07 lwall Locked $
  1366. X
  1367. Xprint "1..10\n";
  1368. X
  1369. Xopen (tmp,'>Cmd.while.tmp') || die "Can't create Cmd.while.tmp.";
  1370. Xprint tmp "tvi925\n";
  1371. Xprint tmp "tvi920\n";
  1372. Xprint tmp "vt100\n";
  1373. Xprint tmp "Amiga\n";
  1374. Xprint tmp "paper\n";
  1375. Xclose tmp;
  1376. X
  1377. X# test "last" command
  1378. X
  1379. Xopen(fh,'Cmd.while.tmp') || die "Can't open Cmd.while.tmp.";
  1380. Xwhile (<fh>) {
  1381. X    last if /vt100/;
  1382. X}
  1383. Xif (!eof && /vt100/) {print "ok 1\n";} else {print "not ok 1 $_\n";}
  1384. X
  1385. X# test "next" command
  1386. X
  1387. X$bad = '';
  1388. Xopen(fh,'Cmd.while.tmp') || die "Can't open Cmd.while.tmp.";
  1389. Xwhile (<fh>) {
  1390. X    next if /vt100/;
  1391. X    $bad = 1 if /vt100/;
  1392. X}
  1393. Xif (!eof || /vt100/ || $bad) {print "not ok 2\n";} else {print "ok 2\n";}
  1394. X
  1395. X# test "redo" command
  1396. X
  1397. X$bad = '';
  1398. Xopen(fh,'Cmd.while.tmp') || die "Can't open Cmd.while.tmp.";
  1399. Xwhile (<fh>) {
  1400. X    if (s/vt100/VT100/g) {
  1401. X    s/VT100/Vt100/g;
  1402. X    redo;
  1403. X    }
  1404. X    $bad = 1 if /vt100/;
  1405. X    $bad = 1 if /VT100/;
  1406. X}
  1407. Xif (!eof || $bad) {print "not ok 3\n";} else {print "ok 3\n";}
  1408. X
  1409. X# now do the same with a label and a continue block
  1410. X
  1411. X# test "last" command
  1412. X
  1413. X$badcont = '';
  1414. Xopen(fh,'Cmd.while.tmp') || die "Can't open Cmd.while.tmp.";
  1415. Xline: while (<fh>) {
  1416. X    if (/vt100/) {last line;}
  1417. X} continue {
  1418. X    $badcont = 1 if /vt100/;
  1419. X}
  1420. Xif (!eof && /vt100/) {print "ok 4\n";} else {print "not ok 4\n";}
  1421. Xif (!$badcont) {print "ok 5\n";} else {print "not ok 5\n";}
  1422. X
  1423. X# test "next" command
  1424. X
  1425. X$bad = '';
  1426. X$badcont = 1;
  1427. Xopen(fh,'Cmd.while.tmp') || die "Can't open Cmd.while.tmp.";
  1428. Xentry: while (<fh>) {
  1429. X    next entry if /vt100/;
  1430. X    $bad = 1 if /vt100/;
  1431. X} continue {
  1432. X    $badcont = '' if /vt100/;
  1433. X}
  1434. Xif (!eof || /vt100/ || $bad) {print "not ok 6\n";} else {print "ok 6\n";}
  1435. Xif (!$badcont) {print "ok 7\n";} else {print "not ok 7\n";}
  1436. X
  1437. X# test "redo" command
  1438. X
  1439. X$bad = '';
  1440. X$badcont = '';
  1441. Xopen(fh,'Cmd.while.tmp') || die "Can't open Cmd.while.tmp.";
  1442. Xloop: while (<fh>) {
  1443. X    if (s/vt100/VT100/g) {
  1444. X    s/VT100/Vt100/g;
  1445. X    redo loop;
  1446. X    }
  1447. X    $bad = 1 if /vt100/;
  1448. X    $bad = 1 if /VT100/;
  1449. X} continue {
  1450. X    $badcont = 1 if /vt100/;
  1451. X}
  1452. Xif (!eof || $bad) {print "not ok 8\n";} else {print "ok 8\n";}
  1453. Xif (!$badcont) {print "ok 9\n";} else {print "not ok 9\n";}
  1454. X
  1455. X`/bin/rm -f Cmd.while.tmp`;
  1456. X
  1457. X#$x = 0;
  1458. X#while (1) {
  1459. X#    if ($x > 1) {last;}
  1460. X#    next;
  1461. X#} continue {
  1462. X#    if ($x++ > 10) {last;}
  1463. X#    next;
  1464. X#}
  1465. X#
  1466. X#if ($x < 10) {print "ok 10\n";} else {print "not ok 10\n";}
  1467. X
  1468. X$i = 9;
  1469. X{
  1470. X    $i++;
  1471. X}
  1472. Xprint "ok $i\n";
  1473. !STUFFY!FUNK!
  1474. echo Extracting eg/scan/scan_suid
  1475. sed >eg/scan/scan_suid <<'!STUFFY!FUNK!' -e 's/X//'
  1476. X#!/usr/bin/perl -P
  1477. X
  1478. X# $Header: scan_suid,v 3.0 89/10/18 15:15:57 lwall Locked $
  1479. X
  1480. X# Look for new setuid root files.
  1481. X
  1482. Xchdir '/usr/adm/private/memories' || die "Can't cd to memories: $!\n";
  1483. X
  1484. X($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
  1485. X   $blksize,$blocks) = stat('oldsuid');
  1486. Xif ($nlink) {
  1487. X    $lasttime = $mtime;
  1488. X    $tmp = $ctime - $atime;
  1489. X    if ($tmp <= 0 || $tmp >= 10) {
  1490. X    print "WARNING: somebody has read oldsuid!\n";
  1491. X    }
  1492. X    $tmp = $ctime - $mtime;
  1493. X    if ($tmp <= 0 || $tmp >= 10) {
  1494. X    print "WARNING: somebody has modified oldsuid!!!\n";
  1495. X    }
  1496. X} else {
  1497. X    $lasttime = time - 60 * 60 * 24;    # one day ago
  1498. X}
  1499. X$thistime = time;
  1500. X
  1501. X#if defined(mc300) || defined(mc500) || defined(mc700)
  1502. Xopen(Find, 'find / -perm -04000 -print |') ||
  1503. X    die "scan_find: can't run find";
  1504. X#else
  1505. Xopen(Find, 'find / \( -fstype nfs -prune \) -o -perm -04000 -ls |') ||
  1506. X    die "scan_find: can't run find";
  1507. X#endif
  1508. X
  1509. Xopen(suid, '>newsuid.tmp');
  1510. X
  1511. Xwhile (<Find>) {
  1512. X
  1513. X#if defined(mc300) || defined(mc500) || defined(mc700)
  1514. X    $x = `/bin/ls -il $_`;
  1515. X    $_ = $x;
  1516. X    s/^ *//;
  1517. X    ($inode,$perm,$links,$owner,$group,$size,$month,$day,$time,$name)
  1518. X      = split;
  1519. X#else
  1520. X    s/^ *//;
  1521. X    ($inode,$blocks,$perm,$links,$owner,$group,$size,$month,$day,$time,$name)
  1522. X      = split;
  1523. X#endif
  1524. X
  1525. X    if ($perm =~ /[sS]/ && $owner eq 'root') {
  1526. X    ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
  1527. X       $blksize,$blocks) = stat($name);
  1528. X    $foo = sprintf("%10s%3s %-8s %-8s%9s %3s %2s %s %s\n",
  1529. X        $perm,$links,$owner,$group,$size,$month,$day,$name,$inode);
  1530. X    print suid $foo;
  1531. X    if ($ctime > $lasttime) {
  1532. X        if ($ctime > $thistime) {
  1533. X        print "Future file: $foo";
  1534. X        }
  1535. X        else {
  1536. X        $ct .= $foo;
  1537. X        }
  1538. X    }
  1539. X    }
  1540. X}
  1541. Xclose(suid);
  1542. X
  1543. Xprint `sort +7 -8 newsuid.tmp >newsuid 2>&1`;
  1544. X$foo = `/bin/diff oldsuid newsuid 2>&1`;
  1545. Xprint "Differences in suid info:\n",$foo if $foo;
  1546. Xprint `mv oldsuid oldoldsuid 2>&1; mv newsuid oldsuid 2>&1`;
  1547. Xprint `touch oldsuid 2>&1;sleep 2 2>&1;chmod o+w oldsuid 2>&1`;
  1548. Xprint `rm -f newsuid.tmp 2>&1`;
  1549. X
  1550. X@ct = split(/\n/,$ct);
  1551. X$ct = '';
  1552. X$* = 1;
  1553. Xwhile ($#ct >= 0) {
  1554. X    $tmp = shift(@ct);
  1555. X    unless ($foo =~ "^>.*$tmp\n") { $ct .= "$tmp\n"; }
  1556. X}
  1557. X
  1558. Xprint "Inode changed since last time:\n",$ct if $ct;
  1559. X
  1560. !STUFFY!FUNK!
  1561. echo Extracting x2p/s2p.man
  1562. sed >x2p/s2p.man <<'!STUFFY!FUNK!' -e 's/X//'
  1563. X.rn '' }`
  1564. X''' $Header: s2p.man,v 3.0 89/10/18 15:35:09 lwall Locked $
  1565. X''' 
  1566. X''' $Log:    s2p.man,v $
  1567. X''' Revision 3.0  89/10/18  15:35:09  lwall
  1568. X''' 3.0 baseline
  1569. X''' 
  1570. X''' Revision 2.0  88/06/05  00:15:59  root
  1571. X''' Baseline version 2.0.
  1572. X''' 
  1573. X''' 
  1574. X.de Sh
  1575. X.br
  1576. X.ne 5
  1577. X.PP
  1578. X\fB\\$1\fR
  1579. X.PP
  1580. X..
  1581. X.de Sp
  1582. X.if t .sp .5v
  1583. X.if n .sp
  1584. X..
  1585. X.de Ip
  1586. X.br
  1587. X.ie \\n.$>=3 .ne \\$3
  1588. X.el .ne 3
  1589. X.IP "\\$1" \\$2
  1590. X..
  1591. X'''
  1592. X'''     Set up \*(-- to give an unbreakable dash;
  1593. X'''     string Tr holds user defined translation string.
  1594. X'''     Bell System Logo is used as a dummy character.
  1595. X'''
  1596. X.tr \(*W-|\(bv\*(Tr
  1597. X.ie n \{\
  1598. X.ds -- \(*W-
  1599. X.if (\n(.H=4u)&(1m=24u) .ds -- \(*W\h'-12u'\(*W\h'-12u'-\" diablo 10 pitch
  1600. X.if (\n(.H=4u)&(1m=20u) .ds -- \(*W\h'-12u'\(*W\h'-8u'-\" diablo 12 pitch
  1601. X.ds L" ""
  1602. X.ds R" ""
  1603. X.ds L' '
  1604. X.ds R' '
  1605. X'br\}
  1606. X.el\{\
  1607. X.ds -- \(em\|
  1608. X.tr \*(Tr
  1609. X.ds L" ``
  1610. X.ds R" ''
  1611. X.ds L' `
  1612. X.ds R' '
  1613. X'br\}
  1614. X.TH S2P 1 NEW
  1615. X.SH NAME
  1616. Xs2p - Sed to Perl translator
  1617. X.SH SYNOPSIS
  1618. X.B s2p [options] filename
  1619. X.SH DESCRIPTION
  1620. X.I S2p
  1621. Xtakes a sed script specified on the command line (or from standard input)
  1622. Xand produces a comparable
  1623. X.I perl
  1624. Xscript on the standard output.
  1625. X.Sh "Options"
  1626. XOptions include:
  1627. X.TP 5
  1628. X.B \-D<number>
  1629. Xsets debugging flags.
  1630. X.TP 5
  1631. X.B \-n
  1632. Xspecifies that this sed script was always invoked with a sed -n.
  1633. XOtherwise a switch parser is prepended to the front of the script.
  1634. X.TP 5
  1635. X.B \-p
  1636. Xspecifies that this sed script was never invoked with a sed -n.
  1637. XOtherwise a switch parser is prepended to the front of the script.
  1638. X.Sh "Considerations"
  1639. XThe perl script produced looks very sed-ish, and there may very well be
  1640. Xbetter ways to express what you want to do in perl.
  1641. XFor instance, s2p does not make any use of the split operator, but you might
  1642. Xwant to.
  1643. X.PP
  1644. XThe perl script you end up with may be either faster or slower than the original
  1645. Xsed script.
  1646. XIf you're only interested in speed you'll just have to try it both ways.
  1647. XOf course, if you want to do something sed doesn't do, you have no choice.
  1648. X.SH ENVIRONMENT
  1649. XS2p uses no environment variables.
  1650. X.SH AUTHOR
  1651. XLarry Wall <lwall@jpl-devvax.Jpl.Nasa.Gov>
  1652. X.SH FILES
  1653. X.SH SEE ALSO
  1654. Xperl    The perl compiler/interpreter
  1655. X.br
  1656. Xa2p    awk to perl translator
  1657. X.SH DIAGNOSTICS
  1658. X.SH BUGS
  1659. X.rn }` ''
  1660. !STUFFY!FUNK!
  1661. echo Extracting t/cmd.subval
  1662. sed >t/cmd.subval <<'!STUFFY!FUNK!' -e 's/X//'
  1663. X#!./perl
  1664. X
  1665. X# $Header: cmd.subval,v 3.0 89/10/18 15:24:52 lwall Locked $
  1666. X
  1667. Xsub foo1 {
  1668. X    'true1';
  1669. X    if ($_[0]) { 'true2'; }
  1670. X}
  1671. X
  1672. Xsub foo2 {
  1673. X    'true1';
  1674. X    if ($_[0]) { return 'true2'; } else { return 'true3'; }
  1675. X    'true0';
  1676. X}
  1677. X
  1678. Xsub foo3 {
  1679. X    'true1';
  1680. X    unless ($_[0]) { 'true2'; }
  1681. X}
  1682. X
  1683. Xsub foo4 {
  1684. X    'true1';
  1685. X    unless ($_[0]) { 'true2'; } else { 'true3'; }
  1686. X}
  1687. X
  1688. Xsub foo5 {
  1689. X    'true1';
  1690. X    'true2' if $_[0];
  1691. X}
  1692. X
  1693. Xsub foo6 {
  1694. X    'true1';
  1695. X    'true2' unless $_[0];
  1696. X}
  1697. X
  1698. Xprint "1..26\n";
  1699. X
  1700. Xif (do foo1(0) eq '0') {print "ok 1\n";} else {print "not ok 1 $foo\n";}
  1701. Xif (do foo1(1) eq 'true2') {print "ok 2\n";} else {print "not ok 2\n";}
  1702. Xif (do foo2(0) eq 'true3') {print "ok 3\n";} else {print "not ok 3\n";}
  1703. Xif (do foo2(1) eq 'true2') {print "ok 4\n";} else {print "not ok 4\n";}
  1704. X
  1705. Xif (do foo3(0) eq 'true2') {print "ok 5\n";} else {print "not ok 5\n";}
  1706. Xif (do foo3(1) eq '1') {print "ok 6\n";} else {print "not ok 6\n";}
  1707. Xif (do foo4(0) eq 'true2') {print "ok 7\n";} else {print "not ok 7\n";}
  1708. Xif (do foo4(1) eq 'true3') {print "ok 8\n";} else {print "not ok 8\n";}
  1709. X
  1710. Xif (do foo5(0) eq '0') {print "ok 9\n";} else {print "not ok 9\n";}
  1711. Xif (do foo5(1) eq 'true2') {print "ok 10\n";} else {print "not ok 10\n";}
  1712. Xif (do foo6(0) eq 'true2') {print "ok 11\n";} else {print "not ok 11\n";}
  1713. Xif (do foo6(1) eq '1') {print "ok 12\n";} else {print "not ok 12 $x\n";}
  1714. X
  1715. X# Now test to see that recursion works using a Fibonacci number generator
  1716. X
  1717. Xsub fib {
  1718. X    local($arg) = @_;
  1719. X    local($foo);
  1720. X    $level++;
  1721. X    if ($arg <= 2) {
  1722. X    $foo = 1;
  1723. X    }
  1724. X    else {
  1725. X    $foo = do fib($arg-1) + do fib($arg-2);
  1726. X    }
  1727. X    $level--;
  1728. X    $foo;
  1729. X}
  1730. X
  1731. X@good = (0,1,1,2,3,5,8,13,21,34,55,89);
  1732. X
  1733. Xfor ($i = 1; $i <= 10; $i++) {
  1734. X    $foo = $i + 12;
  1735. X    if (do fib($i) == $good[$i]) {
  1736. X    print "ok $foo\n";
  1737. X    }
  1738. X    else {
  1739. X    print "not ok $foo\n";
  1740. X    }
  1741. X}
  1742. X
  1743. Xsub ary1 {
  1744. X    (1,2,3);
  1745. X}
  1746. X
  1747. Xprint &ary1 eq 3 ? "ok 23\n" : "not ok 23\n";
  1748. X
  1749. Xprint join(':',&ary1) eq '1:2:3' ? "ok 24\n" : "not ok 24\n";
  1750. X
  1751. Xsub ary2 {
  1752. X    do {
  1753. X    return (1,2,3);
  1754. X    (3,2,1);
  1755. X    };
  1756. X    0;
  1757. X}
  1758. X
  1759. Xprint &ary2 eq 3 ? "ok 25\n" : "not ok 25\n";
  1760. X
  1761. X$x = join(':',&ary2);
  1762. Xprint $x eq '1:2:3' ? "ok 26\n" : "not ok 26 $x\n";
  1763. X
  1764. !STUFFY!FUNK!
  1765. echo Extracting t/op.dbm
  1766. sed >t/op.dbm <<'!STUFFY!FUNK!' -e 's/X//'
  1767. X#!./perl
  1768. X
  1769. X# $Header: op.dbm,v 3.0 89/10/18 15:28:31 lwall Locked $
  1770. X
  1771. Xif (!-r '/usr/include/dbm.h' && !-r '/usr/include/ndbm.h') {
  1772. X    print "1..0\n";
  1773. X    exit;
  1774. X}
  1775. X
  1776. Xprint "1..9\n";
  1777. X
  1778. Xunlink 'Op.dbmx.dir', 'Op.dbmx.pag';
  1779. Xumask(0);
  1780. Xprint (dbmopen(h,'Op.dbmx',0640) ? "ok 1\n" : "not ok 1\n");
  1781. X($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
  1782. X   $blksize,$blocks) = stat('Op.dbmx.pag');
  1783. Xprint (($mode & 0777) == 0640 ? "ok 2\n" : "not ok 2\n");
  1784. Xwhile (($key,$value) = each(h)) {
  1785. X    $i++;
  1786. X}
  1787. Xprint (!$i ? "ok 3\n" : "not ok 3\n");
  1788. X
  1789. X$h{'goner1'} = 'snork';
  1790. X
  1791. X$h{'abc'} = 'ABC';
  1792. X$h{'def'} = 'DEF';
  1793. X$h{'jkl','mno'} = "JKL\034MNO";
  1794. X$h{'a',2,3,4,5} = join("\034",'A',2,3,4,5);
  1795. X$h{'a'} = 'A';
  1796. X$h{'b'} = 'B';
  1797. X$h{'c'} = 'C';
  1798. X$h{'d'} = 'D';
  1799. X$h{'e'} = 'E';
  1800. X$h{'f'} = 'F';
  1801. X$h{'g'} = 'G';
  1802. X$h{'h'} = 'H';
  1803. X$h{'i'} = 'I';
  1804. X
  1805. X$h{'goner2'} = 'snork';
  1806. Xdelete $h{'goner2'};
  1807. X
  1808. Xdbmclose(h);
  1809. Xprint (dbmopen(h,'Op.dbmx',0640) ? "ok 4\n" : "not ok 4\n");
  1810. X
  1811. X$h{'j'} = 'J';
  1812. X$h{'k'} = 'K';
  1813. X$h{'l'} = 'L';
  1814. X$h{'m'} = 'M';
  1815. X$h{'n'} = 'N';
  1816. X$h{'o'} = 'O';
  1817. X$h{'p'} = 'P';
  1818. X$h{'q'} = 'Q';
  1819. X$h{'r'} = 'R';
  1820. X$h{'s'} = 'S';
  1821. X$h{'t'} = 'T';
  1822. X$h{'u'} = 'U';
  1823. X$h{'v'} = 'V';
  1824. X$h{'w'} = 'W';
  1825. X$h{'x'} = 'X';
  1826. X$h{'y'} = 'Y';
  1827. X$h{'z'} = 'Z';
  1828. X
  1829. X$h{'goner3'} = 'snork';
  1830. X
  1831. Xdelete $h{'goner1'};
  1832. Xdelete $h{'goner3'};
  1833. X
  1834. X@keys = keys(%h);
  1835. X@values = values(%h);
  1836. X
  1837. Xif ($#keys == 29 && $#values == 29) {print "ok 5\n";} else {print "not ok 5\n";}
  1838. X
  1839. Xwhile (($key,$value) = each(h)) {
  1840. X    if ($key eq $keys[$i] && $value eq $values[$i] && $key gt $value) {
  1841. X    $key =~ y/a-z/A-Z/;
  1842. X    $i++ if $key eq $value;
  1843. X    }
  1844. X}
  1845. X
  1846. Xif ($i == 30) {print "ok 6\n";} else {print "not ok 6\n";}
  1847. X
  1848. X@keys = ('blurfl', keys(h), 'dyick');
  1849. Xif ($#keys == 31) {print "ok 7\n";} else {print "not ok 7\n";}
  1850. X
  1851. X# check cache overflow and numeric keys and contents
  1852. X$ok = 1;
  1853. Xfor ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; }
  1854. Xfor ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; }
  1855. Xprint ($ok ? "ok 8\n" : "not ok 8\n");
  1856. X
  1857. X($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
  1858. X   $blksize,$blocks) = stat('Op.dbmx.pag');
  1859. Xprint ($size > 0 ? "ok 9\n" : "not ok 9\n");
  1860. X
  1861. Xunlink 'Op.dbmx.dir', 'Op.dbmx.pag';
  1862. !STUFFY!FUNK!
  1863. echo Extracting eg/g/ghosts
  1864. sed >eg/g/ghosts <<'!STUFFY!FUNK!' -e 's/X//'
  1865. X# This first section gives alternate sets defined in terms of the sets given
  1866. X# by the second section.  The order is important--all references must be
  1867. X# forward references.
  1868. X
  1869. XNnd=sun-nd
  1870. Xall=sun+mc+vax
  1871. Xbaseline=sun+mc
  1872. Xsun=sun2+sun3
  1873. Xvax=750+8600
  1874. Xpep=manny+moe+jack
  1875. X
  1876. X# This second section defines the basic sets.  Each host should have a line
  1877. X# that specifies which sets it is a member of.  Extra sets should be separated
  1878. X# by white space.  (The first section isn't strictly necessary, since all sets
  1879. X# could be defined in the second section, but then it wouldn't be so readable.)
  1880. X
  1881. Xbasvax    8600    src
  1882. Xcdb0    sun3        sys
  1883. Xcdb1    sun3        sys
  1884. Xcdb2    sun3        sys
  1885. Xchief    sun3    src
  1886. Xtis0    sun3
  1887. Xmanny    sun3        sys
  1888. Xmoe    sun3        sys
  1889. Xjack    sun3        sys
  1890. Xdisney    sun3        sys
  1891. Xhuey    sun3        nd
  1892. Xdewey    sun3        nd
  1893. Xlouie    sun3        nd
  1894. Xbizet    sun2    src    sys
  1895. Xgif0    mc    src
  1896. Xmc0    mc
  1897. Xdtv0    mc
  1898. !STUFFY!FUNK!
  1899. echo ""
  1900. echo "End of kit 22 (of 24)"
  1901. cat /dev/null >kit22isdone
  1902. run=''
  1903. config=''
  1904. 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
  1905.     if test -f kit${iskit}isdone; then
  1906.     run="$run $iskit"
  1907.     else
  1908.     todo="$todo $iskit"
  1909.     fi
  1910. done
  1911. case $todo in
  1912.     '')
  1913.     echo "You have run all your kits.  Please read README and then type Configure."
  1914.     chmod 755 Configure
  1915.     ;;
  1916.     *)  echo "You have run$run."
  1917.     echo "You still need to run$todo."
  1918.     ;;
  1919. esac
  1920. : Someone might mail this, so...
  1921. exit
  1922.  
  1923.