home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1994 October / usenetsourcesnewsgroupsinfomagicoctober1994disk2.iso / misc / volume18 / perl / part35 < prev    next >
Internet Message Format  |  1991-04-21  |  51KB
  1. From: lwall@netlabs.com (Larry Wall)
  2. Newsgroups: comp.sources.misc
  3. Subject: v18i053:  perl - The perl programming language, Part35/36
  4. Message-ID: <1991Apr19.015003.5207@sparky.IMD.Sterling.COM>
  5. Date: 19 Apr 91 01:50:03 GMT
  6. Approved: kent@sparky.imd.sterling.com
  7. X-Checksum-Snefru: 0418b5d1 a7eb8be9 77d4ba6e 2db23a6c
  8.  
  9. Submitted-by: Larry Wall <lwall@netlabs.com>
  10. Posting-number: Volume 18, Issue 53
  11. Archive-name: perl/part35
  12.  
  13. [There are 36 kits for perl version 4.0.]
  14.  
  15. #! /bin/sh
  16.  
  17. # Make a new directory for the perl sources, cd to it, and run kits 1
  18. # thru 36 through sh.  When all 36 kits have been run, read README.
  19.  
  20. echo "This is perl 4.0 kit 35 (of 36).  If kit 35 is complete, the line"
  21. echo '"'"End of kit 35 (of 36)"'" will echo at the end.'
  22. echo ""
  23. export PATH || (echo "You didn't use sh, you clunch." ; kill $$)
  24. mkdir eg eg/g eg/scan eg/sysvipc eg/van h2pl hints lib msdos msdos/eg os2 t t/base t/cmd t/comp t/io t/op x2p 2>/dev/null
  25. echo Extracting eg/findcp
  26. sed >eg/findcp <<'!STUFFY!FUNK!' -e 's/X//'
  27. X#!/usr/bin/perl
  28. X
  29. X# $Header: findcp,v 4.0 91/03/20 01:09:37 lwall Locked $
  30. X
  31. X# This is a wrapper around the find command that pretends find has a switch
  32. X# of the form -cp host:destination.  It presumes your find implements -ls.
  33. X# It uses tar to do the actual copy.  If your tar knows about the I switch
  34. X# you may prefer to use findtar, since this one has to do the tar in batches.
  35. X
  36. Xsub copy {
  37. X    `tar cf - $list | rsh $desthost cd $destdir '&&' tar xBpf -`;
  38. X}
  39. X
  40. X$sourcedir = $ARGV[0];
  41. Xif ($sourcedir =~ /^\//) {
  42. X    $ARGV[0] = '.';
  43. X    unless (chdir($sourcedir)) { die "Can't find directory $sourcedir: $!"; }
  44. X}
  45. X
  46. X$args = join(' ',@ARGV);
  47. Xif ($args =~ s/-cp *([^ ]+)/-ls/) {
  48. X    $dest = $1;
  49. X    if ($dest =~ /(.*):(.*)/) {
  50. X    $desthost = $1;
  51. X    $destdir = $2;
  52. X    }
  53. X    else {
  54. X    die "Malformed destination--should be host:directory";
  55. X    }
  56. X}
  57. Xelse {
  58. X    die("No destination specified");
  59. X}
  60. X
  61. Xopen(find,"find $args |") || die "Can't run find for you: $!";
  62. X
  63. Xwhile (<find>) {
  64. X    @x = split(' ');
  65. X    if ($x[2] =~ /^d/) { next;}
  66. X    chop($filename = $x[10]);
  67. X    if (length($list) > 5000) {
  68. X    do copy();
  69. X    $list = '';
  70. X    }
  71. X    else {
  72. X    $list .= ' ';
  73. X    }
  74. X    $list .= $filename;
  75. X}
  76. X
  77. Xif ($list) {
  78. X    do copy();
  79. X}
  80. !STUFFY!FUNK!
  81. echo Extracting t/op/push.t
  82. sed >t/op/push.t <<'!STUFFY!FUNK!' -e 's/X//'
  83. X#!./perl
  84. X
  85. X# $Header: push.t,v 4.0 91/03/20 01:54:07 lwall Locked $
  86. X
  87. X@tests = split(/\n/, <<EOF);
  88. X0 3,            0 1 2,        3 4 5 6 7
  89. X0 0 a b c,        ,        a b c 0 1 2 3 4 5 6 7
  90. X8 0 a b c,        ,        0 1 2 3 4 5 6 7 a b c
  91. X7 0 6.5,        ,        0 1 2 3 4 5 6 6.5 7
  92. X1 0 a b c d e f g h i j,,        0 a b c d e f g h i j 1 2 3 4 5 6 7
  93. X0 1 a,            0,        a 1 2 3 4 5 6 7
  94. X1 6 x y z,        1 2 3 4 5 6,    0 x y z 7
  95. X0 7 x y z,        0 1 2 3 4 5 6,    x y z 7
  96. X1 7 x y z,        1 2 3 4 5 6 7,    0 x y z
  97. X4,            4 5 6 7,    0 1 2 3
  98. X-4,            4 5 6 7,    0 1 2 3
  99. XEOF
  100. X
  101. Xprint "1..", 2 + @tests, "\n";
  102. Xdie "blech" unless @tests;
  103. X
  104. X@x = (1,2,3);
  105. Xpush(@x,@x);
  106. Xif (join(':',@x) eq '1:2:3:1:2:3') {print "ok 1\n";} else {print "not ok 1\n";}
  107. Xpush(x,4);
  108. Xif (join(':',@x) eq '1:2:3:1:2:3:4') {print "ok 2\n";} else {print "not ok 2\n";}
  109. X
  110. X$test = 3;
  111. Xforeach $line (@tests) {
  112. X    ($list,$get,$leave) = split(/,\t*/,$line);
  113. X    @list = split(' ',$list);
  114. X    @get = split(' ',$get);
  115. X    @leave = split(' ',$leave);
  116. X    @x = (0,1,2,3,4,5,6,7);
  117. X    @got = splice(@x,@list);
  118. X    if (join(':',@got) eq join(':',@get) &&
  119. X    join(':',@x) eq join(':',@leave)) {
  120. X    print "ok ",$test++,"\n";
  121. X    }
  122. X    else {
  123. X    print "not ok ",$test++," got: @got == @get left: @x == @leave\n";
  124. X    }
  125. X}
  126. X
  127. !STUFFY!FUNK!
  128. echo Extracting t/io/tell.t
  129. sed >t/io/tell.t <<'!STUFFY!FUNK!' -e 's/X//'
  130. X#!./perl
  131. X
  132. X# $Header: tell.t,v 4.0 91/03/20 01:51:14 lwall Locked $
  133. X
  134. Xprint "1..13\n";
  135. X
  136. X$TST = 'tst';
  137. X
  138. Xopen($TST, '../Makefile') || (die "Can't open ../Makefile");
  139. X
  140. Xif (eof(tst)) { print "not ok 1\n"; } else { print "ok 1\n"; }
  141. X
  142. X$firstline = <$TST>;
  143. X$secondpos = tell;
  144. X
  145. X$x = 0;
  146. Xwhile (<tst>) {
  147. X    if (eof) {$x++;}
  148. X}
  149. Xif ($x == 1) { print "ok 2\n"; } else { print "not ok 2\n"; }
  150. X
  151. X$lastpos = tell;
  152. X
  153. Xunless (eof) { print "not ok 3\n"; } else { print "ok 3\n"; }
  154. X
  155. Xif (seek($TST,0,0)) { print "ok 4\n"; } else { print "not ok 4\n"; }
  156. X
  157. Xif (eof) { print "not ok 5\n"; } else { print "ok 5\n"; }
  158. X
  159. Xif ($firstline eq <tst>) { print "ok 6\n"; } else { print "not ok 6\n"; }
  160. X
  161. Xif ($secondpos == tell) { print "ok 7\n"; } else { print "not ok 7\n"; }
  162. X
  163. Xif (seek(tst,0,1)) { print "ok 8\n"; } else { print "not ok 8\n"; }
  164. X
  165. Xif (eof($TST)) { print "not ok 9\n"; } else { print "ok 9\n"; }
  166. X
  167. Xif ($secondpos == tell) { print "ok 10\n"; } else { print "not ok 10\n"; }
  168. X
  169. Xif (seek(tst,0,2)) { print "ok 11\n"; } else { print "not ok 11\n"; }
  170. X
  171. Xif ($lastpos == tell) { print "ok 12\n"; } else { print "not ok 12\n"; }
  172. X
  173. Xunless (eof) { print "not ok 13\n"; } else { print "ok 13\n"; }
  174. !STUFFY!FUNK!
  175. echo Extracting lib/pwd.pl
  176. sed >lib/pwd.pl <<'!STUFFY!FUNK!' -e 's/X//'
  177. X;# pwd.pl - keeps track of current working directory in PWD environment var
  178. X;#
  179. X;# $Header: pwd.pl,v 4.0 91/03/20 01:26:03 lwall Locked $
  180. X;#
  181. X;# $Log:    pwd.pl,v $
  182. X;# Revision 4.0  91/03/20  01:26:03  lwall
  183. X;# 4.0 baseline.
  184. X;# 
  185. X;# Revision 3.0.1.2  91/01/11  18:09:24  lwall
  186. X;# patch42: some .pl files were missing their trailing 1;
  187. X;# 
  188. X;# Revision 3.0.1.1  90/08/09  04:01:24  lwall
  189. X;# patch19: Initial revision
  190. X;# 
  191. X;#
  192. X;# Usage:
  193. X;#    require "pwd.pl";
  194. X;#    &initpwd;
  195. X;#    ...
  196. X;#    &chdir($newdir);
  197. X
  198. Xpackage pwd;
  199. X
  200. Xsub main'initpwd {
  201. X    if ($ENV{'PWD'}) {
  202. X    local($dd,$di) = stat('.');
  203. X    local($pd,$pi) = stat($ENV{'PWD'});
  204. X    return if $di == $pi && $dd == $pd;
  205. X    }
  206. X    chop($ENV{'PWD'} = `pwd`);
  207. X}
  208. X
  209. Xsub main'chdir {
  210. X    local($newdir) = shift;
  211. X    if (chdir $newdir) {
  212. X    if ($newdir =~ m#^/#) {
  213. X        $ENV{'PWD'} = $newdir;
  214. X    }
  215. X    else {
  216. X        local(@curdir) = split(m#/#,$ENV{'PWD'});
  217. X        @curdir = '' unless @curdir;
  218. X        foreach $component (split(m#/#, $newdir)) {
  219. X        next if $component eq '.';
  220. X        pop(@curdir),next if $component eq '..';
  221. X        push(@curdir,$component);
  222. X        }
  223. X        $ENV{'PWD'} = join('/',@curdir) || '/';
  224. X    }
  225. X    }
  226. X    else {
  227. X    0;
  228. X    }
  229. X}
  230. X
  231. X1;
  232. !STUFFY!FUNK!
  233. echo Extracting os2/perldb.dif
  234. sed >os2/perldb.dif <<'!STUFFY!FUNK!' -e 's/X//'
  235. X*** lib/perldb.pl    Tue Oct 23 23:14:20 1990
  236. X--- os2/perldb.pl    Tue Nov 06 21:13:42 1990
  237. X***************
  238. X*** 36,43 ****
  239. X  #
  240. X  #
  241. X
  242. X! open(IN, "</dev/tty") || open(IN,  "<&STDIN");    # so we don't dingle stdin
  243. X! open(OUT,">/dev/tty") || open(OUT, ">&STDOUT");    # so we don't dongle stdout
  244. X  select(OUT);
  245. X  $| = 1;                # for DB'OUT
  246. X  select(STDOUT);
  247. X--- 36,43 ----
  248. X  #
  249. X  #
  250. X
  251. X! open(IN, "<con") || open(IN,  "<&STDIN");    # so we don't dingle stdin
  252. X! open(OUT,">con") || open(OUT, ">&STDOUT");    # so we don't dongle stdout
  253. X  select(OUT);
  254. X  $| = 1;                # for DB'OUT
  255. X  select(STDOUT);
  256. X***************
  257. X*** 517,530 ****
  258. X      s/(.*)/'$1'/ unless /^-?[\d.]+$/;
  259. X  }
  260. X
  261. X! if (-f '.perldb') {
  262. X!     do './.perldb';
  263. X  }
  264. X! elsif (-f "$ENV{'LOGDIR'}/.perldb") {
  265. X!     do "$ENV{'LOGDIR'}/.perldb";
  266. X  }
  267. X! elsif (-f "$ENV{'HOME'}/.perldb") {
  268. X!     do "$ENV{'HOME'}/.perldb";
  269. X  }
  270. X
  271. X  1;
  272. X--- 517,530 ----
  273. X      s/(.*)/'$1'/ unless /^-?[\d.]+$/;
  274. X  }
  275. X
  276. X! if (-f 'perldb.ini') {
  277. X!     do './perldb.ini';
  278. X  }
  279. X! elsif (-f "$ENV{'INIT'}/perldb.ini") {
  280. X!     do "$ENV{'INIT'}/perldb.ini";
  281. X  }
  282. X! elsif (-f "$ENV{'HOME'}/perldb.ini") {
  283. X!     do "$ENV{'HOME'}/perldb.ini";
  284. X  }
  285. X
  286. X  1;
  287. !STUFFY!FUNK!
  288. echo Extracting t/base/lex.t
  289. sed >t/base/lex.t <<'!STUFFY!FUNK!' -e 's/X//'
  290. X#!./perl
  291. X
  292. X# $Header: lex.t,v 4.0 91/03/20 01:49:08 lwall Locked $
  293. X
  294. Xprint "1..18\n";
  295. X
  296. X$ # this is the register <space>
  297. X= 'x';
  298. X
  299. Xprint "#1    :$ : eq :x:\n";
  300. Xif ($  eq 'x') {print "ok 1\n";} else {print "not ok 1\n";}
  301. X
  302. X$x = $#;    # this is the register $#
  303. X
  304. Xif ($x eq '') {print "ok 2\n";} else {print "not ok 2\n";}
  305. X
  306. X$x = $#x;
  307. X
  308. Xif ($x eq '-1') {print "ok 3\n";} else {print "not ok 3\n";}
  309. X
  310. X$x = '\\'; # ';
  311. X
  312. Xif (length($x) == 1) {print "ok 4\n";} else {print "not ok 4\n";}
  313. X
  314. Xeval 'while (0) {
  315. X    print "foo\n";
  316. X}
  317. X/^/ && (print "ok 5\n");
  318. X';
  319. X
  320. Xeval '$foo{1} / 1;';
  321. Xif (!$@) {print "ok 6\n";} else {print "not ok 6\n";}
  322. X
  323. Xeval '$foo = 123+123.4+123e4+123.4E5+123.4e+5+.12;';
  324. X
  325. X$foo = int($foo * 100 + .5);
  326. Xif ($foo eq 2591024652) {print "ok 7\n";} else {print "not ok 7 :$foo:\n";}
  327. X
  328. Xprint <<'EOF';
  329. Xok 8
  330. XEOF
  331. X
  332. X$foo = 'ok 9';
  333. Xprint <<EOF;
  334. X$foo
  335. XEOF
  336. X
  337. Xeval <<\EOE, print $@;
  338. Xprint <<'EOF';
  339. Xok 10
  340. XEOF
  341. X
  342. X$foo = 'ok 11';
  343. Xprint <<EOF;
  344. X$foo
  345. XEOF
  346. XEOE
  347. X
  348. Xprint <<`EOS` . <<\EOF;
  349. Xecho ok 12
  350. XEOS
  351. Xok 13
  352. XEOF
  353. X
  354. Xprint qq/ok 14\n/;
  355. Xprint qq(ok 15\n);
  356. X
  357. Xprint qq
  358. Xok 16\n
  359. X;
  360. X
  361. Xprint q<ok 17
  362. X>;
  363. X
  364. Xprint <<;   # Yow!
  365. Xok 18
  366. X
  367. X# previous line intentionally left blank.
  368. !STUFFY!FUNK!
  369. echo Extracting eg/scan/scan_sudo
  370. sed >eg/scan/scan_sudo <<'!STUFFY!FUNK!' -e 's/X//'
  371. X#!/usr/bin/perl -P
  372. X
  373. X# $Header: scan_sudo,v 4.0 91/03/20 01:13:44 lwall Locked $
  374. X
  375. X# Analyze the sudo log.
  376. X
  377. Xchdir('/usr/adm/private/memories') || die "Can't cd to memories: $!\n";
  378. X
  379. Xif (open(Oldsudo,'oldsudo')) {
  380. X    $maxpos = <Oldsudo>;
  381. X    close Oldsudo;
  382. X}
  383. Xelse {
  384. X    $maxpos = 0;
  385. X    `echo 0 >oldsudo`;
  386. X}
  387. X
  388. Xunless (open(Sudo, '/usr/adm/sudo.log')) {
  389. X    print "Somebody removed sudo.log!!!\n" if $maxpos;
  390. X    exit 0;
  391. X}
  392. X
  393. X($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
  394. X   $blksize,$blocks) = stat(Sudo);
  395. X
  396. Xif ($size < $maxpos) {
  397. X    $maxpos = 0;
  398. X    print "Somebody reset sudo.log!!!\n";
  399. X}
  400. X
  401. Xseek(Sudo,$maxpos,0);
  402. X
  403. Xwhile (<Sudo>) {
  404. X    s/^.* :[ \t]+//;
  405. X    s/ipcrm.*/ipcrm/;
  406. X    s/kill.*/kill/;
  407. X    unless ($seen{$_}++) {
  408. X    push(@seen,$_);
  409. X    }
  410. X    $last = $_;
  411. X}
  412. X$max = tell(Sudo);
  413. X
  414. Xopen(tmp,'|sort >oldsudo.tmp') || die "Can't create tmp file: $!\n";
  415. Xwhile ($_ = pop(@seen)) {
  416. X    print tmp $_;
  417. X}
  418. Xclose(tmp);
  419. Xopen(tmp,'oldsudo.tmp') || die "Can't reopen tmp file: $!\n";
  420. Xwhile (<tmp>) {
  421. X    print $seen{$_},":\t",$_;
  422. X}
  423. X
  424. Xprint `(rm -f oldsudo.tmp; echo $max > oldsudo) 2>&1`;
  425. !STUFFY!FUNK!
  426. echo Extracting t/op/eval.t
  427. sed >t/op/eval.t <<'!STUFFY!FUNK!' -e 's/X//'
  428. X#!./perl
  429. X
  430. X# $Header: eval.t,v 4.0 91/03/20 01:52:20 lwall Locked $
  431. X
  432. Xprint "1..10\n";
  433. X
  434. Xeval 'print "ok 1\n";';
  435. X
  436. Xif ($@ eq '') {print "ok 2\n";} else {print "not ok 2\n";}
  437. X
  438. Xeval "\$foo\n    = # this is a comment\n'ok 3';";
  439. Xprint $foo,"\n";
  440. X
  441. Xeval "\$foo\n    = # this is a comment\n'ok 4\n';";
  442. Xprint $foo;
  443. X
  444. Xprint eval '
  445. X$foo =';        # this tests for a call through yyerror()
  446. Xif ($@ =~ /line 2/) {print "ok 5\n";} else {print "not ok 5\n";}
  447. X
  448. Xprint eval '$foo = /';    # this tests for a call through fatal()
  449. Xif ($@ =~ /Search/) {print "ok 6\n";} else {print "not ok 6\n";}
  450. X
  451. Xprint eval '"ok 7\n";';
  452. X
  453. X# calculate a factorial with recursive evals
  454. X
  455. X$foo = 5;
  456. X$fact = 'if ($foo <= 1) {1;} else {push(@x,$foo--); (eval $fact) * pop(@x);}';
  457. X$ans = eval $fact;
  458. Xif ($ans == 120) {print "ok 8\n";} else {print "not ok 8\n";}
  459. X
  460. X$foo = 5;
  461. X$fact = 'local($foo)=$foo; $foo <= 1 ? 1 : $foo-- * (eval $fact);';
  462. X$ans = eval $fact;
  463. Xif ($ans == 120) {print "ok 9\n";} else {print "not ok 9 $ans\n";}
  464. X
  465. Xopen(try,'>Op.eval');
  466. Xprint try 'print "ok 10\n"; unlink "Op.eval";',"\n";
  467. Xclose try;
  468. X
  469. Xdo 'Op.eval'; print $@;
  470. !STUFFY!FUNK!
  471. echo Extracting x2p/str.h
  472. sed >x2p/str.h <<'!STUFFY!FUNK!' -e 's/X//'
  473. X/* $Header: str.h,v 4.0 91/03/20 01:58:21 lwall Locked $
  474. X *
  475. X *    Copyright (c) 1989, Larry Wall
  476. X *
  477. X *    You may distribute under the terms of the GNU General Public License
  478. X *    as specified in the README file that comes with the perl 3.0 kit.
  479. X *
  480. X * $Log:    str.h,v $
  481. X * Revision 4.0  91/03/20  01:58:21  lwall
  482. X * 4.0 baseline.
  483. X * 
  484. X */
  485. X
  486. Xstruct string {
  487. X    char *    str_ptr;    /* pointer to malloced string */
  488. X    double    str_nval;    /* numeric value, if any */
  489. X    int        str_len;    /* allocated size */
  490. X    int        str_cur;    /* length of str_ptr as a C string */
  491. X    union {
  492. X    STR *str_next;        /* while free, link to next free str */
  493. X    } str_link;
  494. X    char    str_pok;    /* state of str_ptr */
  495. X    char    str_nok;    /* state of str_nval */
  496. X};
  497. X
  498. X#define Nullstr Null(STR*)
  499. X
  500. X/* the following macro updates any magic values this str is associated with */
  501. X
  502. X#define STABSET(x) (x->str_link.str_magic && stabset(x->str_link.str_magic,x))
  503. X
  504. XEXT STR **tmps_list;
  505. XEXT long tmps_max INIT(-1);
  506. X
  507. Xchar *str_2ptr();
  508. Xdouble str_2num();
  509. XSTR *str_mortal();
  510. XSTR *str_make();
  511. XSTR *str_nmake();
  512. Xchar *str_gets();
  513. !STUFFY!FUNK!
  514. echo Extracting msdos/eg/drives.bat
  515. sed >msdos/eg/drives.bat <<'!STUFFY!FUNK!' -e 's/X//'
  516. X@REM=("
  517. X@perl %0.bat %1 %2 %3 %4 %5 %6 %7 %8 %9
  518. X@end ") if 0 ;
  519. X
  520. X#
  521. X# Test the ioctl function for MS-DOS.  Provide a list of drives and their
  522. X# characteristics.
  523. X#
  524. X# By Diomidis Spinellis.
  525. X#
  526. X
  527. X@fdnum = ("STDIN", "STDOUT", "STDERR");
  528. X$maxdrives = 15;
  529. Xfor ($i = 3; $i < $maxdrives; $i++) {
  530. X    open("FD$i", "nul");
  531. X    @fdnum[$i - 1] = "FD$i";
  532. X}
  533. X@mediatype = (
  534. X    "320/360 k floppy drive",
  535. X    "1.2M floppy",
  536. X    "720K floppy",
  537. X    "8'' single density floppy",
  538. X    "8'' double density floppy",
  539. X    "fixed disk",
  540. X    "tape drive",
  541. X    "1.44M floppy",
  542. X    "other"
  543. X);
  544. Xprint "The system has the following drives:\n";
  545. Xfor ($i = 1; $i < $maxdrives; $i++) {
  546. X    if ($ret = ioctl(@fdnum[$i], 8, 0)) {
  547. X        $type = ($ret == 0) ? "removable" : "fixed";
  548. X        $ret = ioctl(@fdnum[$i], 9, 0);
  549. X        $location = ($ret & 0x800) ? "local" : "remote";
  550. X        ioctl(@fdnum[$i], 0x860d, $param);
  551. X        @par = unpack("CCSSSC31S", $param);
  552. X        $lock = (@par[2] & 2) ? "supporting door lock" : "not supporting door lock";
  553. X        printf "%c:$type $location @mediatype[@par[1]] @par[3] cylinders @par[6]
  554. X sectors/track $lock\n", ord('A') + $i - 1;
  555. X    }
  556. X}
  557. !STUFFY!FUNK!
  558. echo Extracting t/op/each.t
  559. sed >t/op/each.t <<'!STUFFY!FUNK!' -e 's/X//'
  560. X#!./perl
  561. X
  562. X# $Header: each.t,v 4.0 91/03/20 01:52:14 lwall Locked $
  563. X
  564. Xprint "1..3\n";
  565. X
  566. X$h{'abc'} = 'ABC';
  567. X$h{'def'} = 'DEF';
  568. X$h{'jkl','mno'} = "JKL\034MNO";
  569. X$h{'a',2,3,4,5} = join("\034",'A',2,3,4,5);
  570. X$h{'a'} = 'A';
  571. X$h{'b'} = 'B';
  572. X$h{'c'} = 'C';
  573. X$h{'d'} = 'D';
  574. X$h{'e'} = 'E';
  575. X$h{'f'} = 'F';
  576. X$h{'g'} = 'G';
  577. X$h{'h'} = 'H';
  578. X$h{'i'} = 'I';
  579. X$h{'j'} = 'J';
  580. X$h{'k'} = 'K';
  581. X$h{'l'} = 'L';
  582. X$h{'m'} = 'M';
  583. X$h{'n'} = 'N';
  584. X$h{'o'} = 'O';
  585. X$h{'p'} = 'P';
  586. X$h{'q'} = 'Q';
  587. X$h{'r'} = 'R';
  588. X$h{'s'} = 'S';
  589. X$h{'t'} = 'T';
  590. X$h{'u'} = 'U';
  591. X$h{'v'} = 'V';
  592. X$h{'w'} = 'W';
  593. X$h{'x'} = 'X';
  594. X$h{'y'} = 'Y';
  595. X$h{'z'} = 'Z';
  596. X
  597. X@keys = keys %h;
  598. X@values = values %h;
  599. X
  600. Xif ($#keys == 29 && $#values == 29) {print "ok 1\n";} else {print "not ok 1\n";}
  601. X
  602. Xwhile (($key,$value) = each(h)) {
  603. X    if ($key eq $keys[$i] && $value eq $values[$i] && $key gt $value) {
  604. X    $key =~ y/a-z/A-Z/;
  605. X    $i++ if $key eq $value;
  606. X    }
  607. X}
  608. X
  609. Xif ($i == 30) {print "ok 2\n";} else {print "not ok 2\n";}
  610. X
  611. X@keys = ('blurfl', keys(%h), 'dyick');
  612. Xif ($#keys == 31) {print "ok 3\n";} else {print "not ok 3\n";}
  613. !STUFFY!FUNK!
  614. echo Extracting lib/getopt.pl
  615. sed >lib/getopt.pl <<'!STUFFY!FUNK!' -e 's/X//'
  616. X;# $Header: getopt.pl,v 4.0 91/03/20 01:25:11 lwall Locked $
  617. X
  618. X;# Process single-character switches with switch clustering.  Pass one argument
  619. X;# which is a string containing all switches that take an argument.  For each
  620. X;# switch found, sets $opt_x (where x is the switch name) to the value of the
  621. X;# argument, or 1 if no argument.  Switches which take an argument don't care
  622. X;# whether there is a space between the switch and the argument.
  623. X
  624. X;# Usage:
  625. X;#    do Getopt('oDI');  # -o, -D & -I take arg.  Sets opt_* as a side effect.
  626. X
  627. Xsub Getopt {
  628. X    local($argumentative) = @_;
  629. X    local($_,$first,$rest);
  630. X    local($[) = 0;
  631. X
  632. X    while (($_ = $ARGV[0]) =~ /^-(.)(.*)/) {
  633. X    ($first,$rest) = ($1,$2);
  634. X    if (index($argumentative,$first) >= $[) {
  635. X        if ($rest ne '') {
  636. X        shift(@ARGV);
  637. X        }
  638. X        else {
  639. X        shift(@ARGV);
  640. X        $rest = shift(@ARGV);
  641. X        }
  642. X        eval "\$opt_$first = \$rest;";
  643. X    }
  644. X    else {
  645. X        eval "\$opt_$first = 1;";
  646. X        if ($rest ne '') {
  647. X        $ARGV[0] = "-$rest";
  648. X        }
  649. X        else {
  650. X        shift(@ARGV);
  651. X        }
  652. X    }
  653. X    }
  654. X}
  655. X
  656. X1;
  657. !STUFFY!FUNK!
  658. echo Extracting lib/look.pl
  659. sed >lib/look.pl <<'!STUFFY!FUNK!' -e 's/X//'
  660. X;# Usage: &look(*FILEHANDLE,$key,$dict,$fold)
  661. X
  662. X;# Sets file position in FILEHANDLE to be first line greater than or equal
  663. X;# (stringwise) to $key.  Pass flags for dictionary order and case folding.
  664. X
  665. Xsub look {
  666. X    local(*FH,$key,$dict,$fold) = @_;
  667. X    local($max,$min,$mid,$_);
  668. X    local($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
  669. X       $blksize,$blocks) = stat(FH);
  670. X    $blksize = 8192 unless $blksize;
  671. X    $key =~ s/[^\w\s]//g if $dict;
  672. X    $key =~ y/A-Z/a-z/ if $fold;
  673. X    $max = int($size / $blksize);
  674. X    while ($max - $min > 1) {
  675. X    $mid = int(($max + $min) / 2);
  676. X    seek(FH,$mid * $blksize,0);
  677. X    $_ = <FH> if $mid;        # probably a partial line
  678. X    $_ = <FH>;
  679. X    chop;
  680. X    s/[^\w\s]//g if $dict;
  681. X    y/A-Z/a-z/ if $fold;
  682. X    if ($_ lt $key) {
  683. X        $min = $mid;
  684. X    }
  685. X    else {
  686. X        $max = $mid;
  687. X    }
  688. X    }
  689. X    $min *= $blksize;
  690. X    seek(FH,$min,0);
  691. X    <FH> if $min;
  692. X    while (<FH>) {
  693. X    chop;
  694. X    s/[^\w\s]//g if $dict;
  695. X    y/A-Z/a-z/ if $fold;
  696. X    last if $_ ge $key;
  697. X    $min = tell(FH);
  698. X    }
  699. X    seek(FH,$min,0);
  700. X    $min;
  701. X}
  702. X
  703. X1;
  704. !STUFFY!FUNK!
  705. echo Extracting t/op/time.t
  706. sed >t/op/time.t <<'!STUFFY!FUNK!' -e 's/X//'
  707. X#!./perl
  708. X
  709. X# $Header: time.t,v 4.0 91/03/20 01:55:09 lwall Locked $
  710. X
  711. Xprint "1..5\n";
  712. X
  713. X($beguser,$begsys) = times;
  714. X
  715. X$beg = time;
  716. X
  717. Xwhile (($now = time) == $beg) {}
  718. X
  719. Xif ($now > $beg && $now - $beg < 10){print "ok 1\n";} else {print "not ok 1\n";}
  720. X
  721. Xfor ($i = 0; $i < 100000; $i++) {
  722. X    ($nowuser, $nowsys) = times;
  723. X    $i = 200000 if $nowuser > $beguser && $nowsys > $begsys;
  724. X    last if time - $beg > 20;
  725. X}
  726. X
  727. Xif ($i >= 200000) {print "ok 2\n";} else {print "not ok 2\n";}
  728. X
  729. X($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($beg);
  730. X($xsec,$foo) = localtime($now);
  731. X$localyday = $yday;
  732. X
  733. Xif ($sec != $xsec && $mday && $year)
  734. X    {print "ok 3\n";}
  735. Xelse
  736. X    {print "not ok 3\n";}
  737. X
  738. X($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = gmtime($beg);
  739. X($xsec,$foo) = localtime($now);
  740. X
  741. Xif ($sec != $xsec && $mday && $year)
  742. X    {print "ok 4\n";}
  743. Xelse
  744. X    {print "not ok 4\n";}
  745. X
  746. Xif (index(" :0:1:-1:365:366:-365:-366:",':' . ($localyday - $yday) . ':') > 0)
  747. X    {print "ok 5\n";}
  748. Xelse
  749. X    {print "not ok 5\n";}
  750. !STUFFY!FUNK!
  751. echo Extracting x2p/handy.h
  752. sed >x2p/handy.h <<'!STUFFY!FUNK!' -e 's/X//'
  753. X/* $RCSfile: handy.h,v $$Revision: 4.0.1.1 $$Date: 91/04/12 09:29:08 $
  754. X *
  755. X *    Copyright (c) 1989, Larry Wall
  756. X *
  757. X *    You may distribute under the terms of the GNU General Public License
  758. X *    as specified in the README file that comes with the perl 3.0 kit.
  759. X *
  760. X * $Log:    handy.h,v $
  761. X * Revision 4.0.1.1  91/04/12  09:29:08  lwall
  762. X * patch1: random cleanup in cpp namespace
  763. X * 
  764. X * Revision 4.0  91/03/20  01:57:45  lwall
  765. X * 4.0 baseline.
  766. X * 
  767. X */
  768. X
  769. X#define Null(type) ((type)0)
  770. X#define Nullch Null(char*)
  771. X#define Nullfp Null(FILE*)
  772. X
  773. X#define bool char
  774. X#ifdef TRUE
  775. X#undef TRUE
  776. X#endif
  777. X#ifdef FALSE
  778. X#undef FALSE
  779. X#endif
  780. X#define TRUE (1)
  781. X#define FALSE (0)
  782. X
  783. X#define Ctl(ch) (ch & 037)
  784. X
  785. X#define strNE(s1,s2) (strcmp(s1,s2))
  786. X#define strEQ(s1,s2) (!strcmp(s1,s2))
  787. X#define strLT(s1,s2) (strcmp(s1,s2) < 0)
  788. X#define strLE(s1,s2) (strcmp(s1,s2) <= 0)
  789. X#define strGT(s1,s2) (strcmp(s1,s2) > 0)
  790. X#define strGE(s1,s2) (strcmp(s1,s2) >= 0)
  791. X#define strnNE(s1,s2,l) (strncmp(s1,s2,l))
  792. X#define strnEQ(s1,s2,l) (!strncmp(s1,s2,l))
  793. !STUFFY!FUNK!
  794. echo Extracting t/op/do.t
  795. sed >t/op/do.t <<'!STUFFY!FUNK!' -e 's/X//'
  796. X#!./perl
  797. X
  798. X# $Header: do.t,v 4.0 91/03/20 01:52:08 lwall Locked $
  799. X
  800. Xsub foo1
  801. X{
  802. X    print $_[0];
  803. X    'value';
  804. X}
  805. X
  806. Xsub foo2
  807. X{
  808. X    shift(_);
  809. X    print $_[0];
  810. X    $x = 'value';
  811. X    $x;
  812. X}
  813. X
  814. Xprint "1..15\n";
  815. X
  816. X$_[0] = "not ok 1\n";
  817. X$result = do foo1("ok 1\n");
  818. Xprint "#2\t:$result: eq :value:\n";
  819. Xif ($result EQ 'value') { print "ok 2\n"; } else { print "not ok 2\n"; }
  820. Xif ($_[0] EQ "not ok 1\n") { print "ok 3\n"; } else { print "not ok 3\n"; }
  821. X
  822. X$_[0] = "not ok 4\n";
  823. X$result = do foo2("not ok 4\n","ok 4\n","not ok 4\n");
  824. Xprint "#5\t:$result: eq :value:\n";
  825. Xif ($result EQ 'value') { print "ok 5\n"; } else { print "not ok 5\n"; }
  826. Xif ($_[0] EQ "not ok 4\n") { print "ok 6\n"; } else { print "not ok 6\n"; }
  827. X
  828. X$result = do{print "ok 7\n"; 'value';};
  829. Xprint "#8\t:$result: eq :value:\n";
  830. Xif ($result EQ 'value') { print "ok 8\n"; } else { print "not ok 8\n"; }
  831. X
  832. Xsub blather {
  833. X    print @_;
  834. X}
  835. X
  836. Xdo blather("ok 9\n","ok 10\n");
  837. X@x = ("ok 11\n", "ok 12\n");
  838. X@y = ("ok 14\n", "ok 15\n");
  839. Xdo blather(@x,"ok 13\n",@y);
  840. !STUFFY!FUNK!
  841. echo Extracting eg/sysvipc/ipcshm
  842. sed >eg/sysvipc/ipcshm <<'!STUFFY!FUNK!' -e 's/X//'
  843. X#!/usr/bin/perl
  844. Xeval 'exec /usr/bin/perl -S $0 ${1+"$@"}'
  845. X    if 0;
  846. X
  847. Xrequire 'sys/ipc.ph';
  848. Xrequire 'sys/shm.ph';
  849. X
  850. X$| = 1;
  851. X
  852. X$mode = shift;
  853. Xdie "usage: ipcshm {r|s}\n" unless $mode =~ /^[rs]$/;
  854. X$send = ($mode eq "s");
  855. X
  856. X$SIZE = 32;
  857. X$id = shmget(0x1234, $SIZE, ($send ? 0 : &IPC_CREAT) | 0644);
  858. Xdie "Can't get shared memory: $!\n" unless defined($id);
  859. Xprint "shared memory id: $id\n";
  860. X
  861. Xif ($send) {
  862. X    while (<STDIN>) {
  863. X        chop;
  864. X        unless (shmwrite($id, pack("La*", length($_), $_), 0, $SIZE)) {
  865. X            die "Can't write to shared memory: $!\n";
  866. X        }
  867. X    }
  868. X}
  869. Xelse {
  870. X    $SIG{'INT'} = $SIG{'QUIT'} = "leave";
  871. X    for (;;) {
  872. X        $_ = <STDIN>;
  873. X        unless (shmread($id, $_, 0, $SIZE)) {
  874. X            die "Can't read shared memory: $!\n";
  875. X        }
  876. X        $len = unpack("L", $_);
  877. X        $message = substr($_, length(pack("L",0)), $len);
  878. X        printf "[%d] %s\n", $len, $message;
  879. X    }
  880. X}
  881. X
  882. X&leave;
  883. X
  884. Xsub leave {
  885. X    if (!$send) {
  886. X        $x = shmctl($id, &IPC_RMID, 0);
  887. X        if (!defined($x) || $x < 0) {
  888. X            die "Can't remove shared memory: $!\n";
  889. X        }
  890. X    }
  891. X    exit;
  892. X}
  893. !STUFFY!FUNK!
  894. echo Extracting regexp.h
  895. sed >regexp.h <<'!STUFFY!FUNK!' -e 's/X//'
  896. X/*
  897. X * Definitions etc. for regexp(3) routines.
  898. X *
  899. X * Caveat:  this is V8 regexp(3) [actually, a reimplementation thereof],
  900. X * not the System V one.
  901. X */
  902. X
  903. X/* $Header: regexp.h,v 4.0 91/03/20 01:39:23 lwall Locked $
  904. X *
  905. X * $Log:    regexp.h,v $
  906. X * Revision 4.0  91/03/20  01:39:23  lwall
  907. X * 4.0 baseline.
  908. X * 
  909. X */
  910. X
  911. Xtypedef struct regexp {
  912. X    char **startp;
  913. X    char **endp;
  914. X    STR *regstart;        /* Internal use only. */
  915. X    char *regstclass;
  916. X    STR *regmust;        /* Internal use only. */
  917. X    int regback;        /* Can regmust locate first try? */
  918. X    char *precomp;        /* pre-compilation regular expression */
  919. X    char *subbase;        /* saved string so \digit works forever */
  920. X    char *subend;        /* end of subbase */
  921. X    char reganch;        /* Internal use only. */
  922. X    char do_folding;    /* do case-insensitive match? */
  923. X    char lastparen;        /* last paren matched */
  924. X    char nparens;        /* number of parentheses */
  925. X    char program[1];    /* Unwarranted chumminess with compiler. */
  926. X} regexp;
  927. X
  928. Xregexp *regcomp();
  929. Xint regexec();
  930. !STUFFY!FUNK!
  931. echo Extracting t/op/magic.t
  932. sed >t/op/magic.t <<'!STUFFY!FUNK!' -e 's/X//'
  933. X#!./perl
  934. X
  935. X# $Header: magic.t,v 4.0 91/03/20 01:53:35 lwall Locked $
  936. X
  937. X$| = 1;        # command buffering
  938. X
  939. Xprint "1..5\n";
  940. X
  941. Xeval '$ENV{"foo"} = "hi there";';    # check that ENV is inited inside eval
  942. Xif (`echo \$foo` eq "hi there\n") {print "ok 1\n";} else {print "not ok 1\n";}
  943. X
  944. Xunlink 'ajslkdfpqjsjfk';
  945. X$! = 0;
  946. Xopen(foo,'ajslkdfpqjsjfk');
  947. Xif ($! == 2) {print "ok 2\n";} else {print "not ok 2\n";}
  948. X
  949. X# the next tests are embedded inside system simply because sh spits out
  950. X# a newline onto stderr when a child process kills itself with SIGINT.
  951. X
  952. Xsystem './perl',
  953. X'-e', '$| = 1;        # command buffering',
  954. X
  955. X'-e', '$SIG{"INT"} = "ok3"; kill 2,$$;',
  956. X'-e', '$SIG{"INT"} = "IGNORE"; kill 2,$$; print "ok 4\n";',
  957. X'-e', '$SIG{"INT"} = "DEFAULT"; kill 2,$$; print "not ok\n";',
  958. X
  959. X'-e', 'sub ok3 { print "ok 3\n" if pop(@_) eq "INT"; }';
  960. X
  961. X@val1 = @ENV{keys(%ENV)};    # can we slice ENV?
  962. X@val2 = values(%ENV);
  963. X
  964. Xprint join(':',@val1) eq join(':',@val2) ? "ok 5\n" : "not ok 5\n";
  965. !STUFFY!FUNK!
  966. echo Extracting msdos/eg/lf.bat
  967. sed >msdos/eg/lf.bat <<'!STUFFY!FUNK!' -e 's/X//'
  968. X@REM=("
  969. X@perl %0.bat %1 %2 %3 %4 %5 %6 %7 %8 %9
  970. X@end ") if 0 ;
  971. X
  972. X# Convert all the files in the current directory from MS-DOS to unix
  973. X# line ending conventions.
  974. X#
  975. X# By Diomidis Spinellis
  976. X#
  977. Xopen(FILES, 'find . -print |');
  978. Xwhile ($file = <FILES>) {
  979. X    $file =^ s/[\n\r]//;
  980. X    if (-f $file) {
  981. X        if (-B $file) {
  982. X            print STDERR "Skipping binary file $file\n";
  983. X            next;
  984. X        }
  985. X        ($dev, $ino, $mode, $nlink, $uid, $gid, $rdev, $size, $atime, $mtime, $ctime,
  986. X $blksize, $blocks) = stat($file);
  987. X        open(IFILE, "$file");
  988. X        open(OFILE, ">xl$$");
  989. X        binmode OFILE || die "binmode xl$$: $!\n";
  990. X        while (<IFILE>) {
  991. X            print OFILE;
  992. X        }
  993. X        close(OFILE) || die "close xl$$: $!\n";
  994. X        close(IFILE) || die "close $file: $!\n";
  995. X        unlink($file) || die "unlink $file: $!\n";
  996. X        rename("xl$$", $file) || die "rename(xl$$, $file): $!\n";
  997. X        chmod($mode, $file) || die "chmod($mode, $file: $!\n";
  998. X        utime($atime, $mtime, $file) || die "utime($atime, $mtime, $file): $!\n";
  999. X    }
  1000. X}
  1001. !STUFFY!FUNK!
  1002. echo Extracting t/cmd/for.t
  1003. sed >t/cmd/for.t <<'!STUFFY!FUNK!' -e 's/X//'
  1004. X#!./perl
  1005. X
  1006. X# $Header: for.t,v 4.0 91/03/20 01:49:26 lwall Locked $
  1007. X
  1008. Xprint "1..7\n";
  1009. X
  1010. Xfor ($i = 0; $i <= 10; $i++) {
  1011. X    $x[$i] = $i;
  1012. X}
  1013. X$y = $x[10];
  1014. Xprint "#1    :$y: eq :10:\n";
  1015. X$y = join(' ', @x);
  1016. Xprint "#1    :$y: eq :0 1 2 3 4 5 6 7 8 9 10:\n";
  1017. Xif (join(' ', @x) eq '0 1 2 3 4 5 6 7 8 9 10') {
  1018. X    print "ok 1\n";
  1019. X} else {
  1020. X    print "not ok 1\n";
  1021. X}
  1022. X
  1023. X$i = $c = 0;
  1024. Xfor (;;) {
  1025. X    $c++;
  1026. X    last if $i++ > 10;
  1027. X}
  1028. Xif ($c == 12) {print "ok 2\n";} else {print "not ok 2\n";}
  1029. X
  1030. X$foo = 3210;
  1031. X@ary = (1,2,3,4,5);
  1032. Xforeach $foo (@ary) {
  1033. X    $foo *= 2;
  1034. X}
  1035. Xif (join('',@ary) eq '246810') {print "ok 3\n";} else {print "not ok 3\n";}
  1036. X
  1037. Xfor (@ary) {
  1038. X    s/(.*)/ok $1\n/;
  1039. X}
  1040. X
  1041. Xprint $ary[1];
  1042. X
  1043. X# test for internal scratch array generation
  1044. X# this also tests that $foo was restored to 3210 after test 3
  1045. Xfor (split(' ','a b c d e')) {
  1046. X    $foo .= $_;
  1047. X}
  1048. Xif ($foo eq '3210abcde') {print "ok 5\n";} else {print "not ok 5 $foo\n";}
  1049. X
  1050. Xforeach $foo (("ok 6\n","ok 7\n")) {
  1051. X    print $foo;
  1052. X}
  1053. !STUFFY!FUNK!
  1054. echo Extracting t/base/term.t
  1055. sed >t/base/term.t <<'!STUFFY!FUNK!' -e 's/X//'
  1056. X#!./perl
  1057. X
  1058. X# $Header: term.t,v 4.0 91/03/20 01:49:17 lwall Locked $
  1059. X
  1060. Xprint "1..6\n";
  1061. X
  1062. X# check "" interpretation
  1063. X
  1064. X$x = "\n";
  1065. Xif ($x lt ' ') {print "ok 1\n";} else {print "not ok 1\n";}
  1066. X
  1067. X# check `` processing
  1068. X
  1069. X$x = `echo hi there`;
  1070. Xif ($x eq "hi there\n") {print "ok 2\n";} else {print "not ok 2\n";}
  1071. X
  1072. X# check $#array
  1073. X
  1074. X$x[0] = 'foo';
  1075. X$x[1] = 'foo';
  1076. X$tmp = $#x;
  1077. Xprint "#3\t:$tmp: == :1:\n";
  1078. Xif ($#x == '1') {print "ok 3\n";} else {print "not ok 3\n";}
  1079. X
  1080. X# check numeric literal
  1081. X
  1082. X$x = 1;
  1083. Xif ($x == '1') {print "ok 4\n";} else {print "not ok 4\n";}
  1084. X
  1085. X# check <> pseudoliteral
  1086. X
  1087. Xopen(try, "/dev/null") || (die "Can't open /dev/null.");
  1088. Xif (<try> eq '') {
  1089. X    print "ok 5\n";
  1090. X}
  1091. Xelse {
  1092. X    print "not ok 5\n";
  1093. X    die "/dev/null IS NOT A CHARACTER SPECIAL FILE!!!!\n" unless -c '/dev/null';
  1094. X}
  1095. X
  1096. Xopen(try, "../Makefile") || (die "Can't open ../Makefile.");
  1097. Xif (<try> ne '') {print "ok 6\n";} else {print "not ok 6\n";}
  1098. !STUFFY!FUNK!
  1099. echo Extracting lib/getopts.pl
  1100. sed >lib/getopts.pl <<'!STUFFY!FUNK!' -e 's/X//'
  1101. X;# getopts.pl - a better getopt.pl
  1102. X
  1103. X;# Usage:
  1104. X;#      do Getopts('a:bc');  # -a takes arg. -b & -c not. Sets opt_* as a
  1105. X;#                           #  side effect.
  1106. X
  1107. Xsub Getopts {
  1108. X    local($argumentative) = @_;
  1109. X    local(@args,$_,$first,$rest,$errs);
  1110. X    local($[) = 0;
  1111. X
  1112. X    @args = split( / */, $argumentative );
  1113. X    while(($_ = $ARGV[0]) =~ /^-(.)(.*)/) {
  1114. X    ($first,$rest) = ($1,$2);
  1115. X    $pos = index($argumentative,$first);
  1116. X    if($pos >= $[) {
  1117. X        if($args[$pos+1] eq ':') {
  1118. X        shift(@ARGV);
  1119. X        if($rest eq '') {
  1120. X            $rest = shift(@ARGV);
  1121. X        }
  1122. X        eval "\$opt_$first = \$rest;";
  1123. X        }
  1124. X        else {
  1125. X        eval "\$opt_$first = 1";
  1126. X        if($rest eq '') {
  1127. X            shift(@ARGV);
  1128. X        }
  1129. X        else {
  1130. X            $ARGV[0] = "-$rest";
  1131. X        }
  1132. X        }
  1133. X    }
  1134. X    else {
  1135. X        print STDERR "Unknown option: $first\n";
  1136. X        ++$errs;
  1137. X        if($rest ne '') {
  1138. X        $ARGV[0] = "-$rest";
  1139. X        }
  1140. X        else {
  1141. X        shift(@ARGV);
  1142. X        }
  1143. X    }
  1144. X    }
  1145. X    $errs == 0;
  1146. X}
  1147. X
  1148. X1;
  1149. !STUFFY!FUNK!
  1150. echo Extracting t/io/argv.t
  1151. sed >t/io/argv.t <<'!STUFFY!FUNK!' -e 's/X//'
  1152. X#!./perl
  1153. X
  1154. X# $Header: argv.t,v 4.0 91/03/20 01:50:46 lwall Locked $
  1155. X
  1156. Xprint "1..5\n";
  1157. X
  1158. Xopen(try, '>Io.argv.tmp') || (die "Can't open temp file.");
  1159. Xprint try "a line\n";
  1160. Xclose try;
  1161. X
  1162. X$x = `./perl -e 'while (<>) {print \$.,\$_;}' Io.argv.tmp Io.argv.tmp`;
  1163. X
  1164. Xif ($x eq "1a line\n2a line\n") {print "ok 1\n";} else {print "not ok 1\n";}
  1165. X
  1166. X$x = `echo foo|./perl -e 'while (<>) {print $_;}' Io.argv.tmp -`;
  1167. X
  1168. Xif ($x eq "a line\nfoo\n") {print "ok 2\n";} else {print "not ok 2\n";}
  1169. X
  1170. X$x = `echo foo|./perl -e 'while (<>) {print $_;}'`;
  1171. X
  1172. Xif ($x eq "foo\n") {print "ok 3\n";} else {print "not ok 3 :$x:\n";}
  1173. X
  1174. X@ARGV = ('Io.argv.tmp', 'Io.argv.tmp', '/dev/null', 'Io.argv.tmp');
  1175. Xwhile (<>) {
  1176. X    $y .= $. . $_;
  1177. X    if (eof()) {
  1178. X    if ($. == 3) {print "ok 4\n";} else {print "not ok 4\n";}
  1179. X    }
  1180. X}
  1181. X
  1182. Xif ($y eq "1a line\n2a line\n3a line\n")
  1183. X    {print "ok 5\n";}
  1184. Xelse
  1185. X    {print "not ok 5\n";}
  1186. X
  1187. X`/bin/rm -f Io.argv.tmp`;
  1188. !STUFFY!FUNK!
  1189. echo Extracting t/io/pipe.t
  1190. sed >t/io/pipe.t <<'!STUFFY!FUNK!' -e 's/X//'
  1191. X#!./perl
  1192. X
  1193. X# $Header: pipe.t,v 4.0 91/03/20 01:51:02 lwall Locked $
  1194. X
  1195. X$| = 1;
  1196. Xprint "1..8\n";
  1197. X
  1198. Xopen(PIPE, "|-") || (exec 'tr', '[A-Z]', '[a-z]');
  1199. Xprint PIPE "OK 1\n";
  1200. Xprint PIPE "ok 2\n";
  1201. Xclose PIPE;
  1202. X
  1203. Xif (open(PIPE, "-|")) {
  1204. X    while(<PIPE>) {
  1205. X    s/^not //;
  1206. X    print;
  1207. X    }
  1208. X}
  1209. Xelse {
  1210. X    print STDOUT "not ok 3\n";
  1211. X    exec 'echo', 'not ok 4';
  1212. X}
  1213. X
  1214. Xpipe(READER,WRITER) || die "Can't open pipe";
  1215. X
  1216. Xif ($pid = fork) {
  1217. X    close WRITER;
  1218. X    while(<READER>) {
  1219. X    s/^not //;
  1220. X    y/A-Z/a-z/;
  1221. X    print;
  1222. X    }
  1223. X}
  1224. Xelse {
  1225. X    die "Couldn't fork" unless defined $pid;
  1226. X    close READER;
  1227. X    print WRITER "not ok 5\n";
  1228. X    open(STDOUT,">&WRITER") || die "Can't dup WRITER to STDOUT";
  1229. X    close WRITER;
  1230. X    exec 'echo', 'not ok 6';
  1231. X}
  1232. X
  1233. X
  1234. Xpipe(READER,WRITER) || die "Can't open pipe";
  1235. Xclose READER;
  1236. X
  1237. X$SIG{'PIPE'} = 'broken_pipe';
  1238. X
  1239. Xsub broken_pipe {
  1240. X    print "ok 7\n";
  1241. X}
  1242. X
  1243. Xprint WRITER "not ok 7\n";
  1244. Xclose WRITER;
  1245. X
  1246. Xprint "ok 8\n";
  1247. !STUFFY!FUNK!
  1248. echo Extracting msdos/eg/crlf.bat
  1249. sed >msdos/eg/crlf.bat <<'!STUFFY!FUNK!' -e 's/X//'
  1250. X@REM=("
  1251. X@perl %0.bat %1 %2 %3 %4 %5 %6 %7 %8 %9
  1252. X@end ") if 0 ;
  1253. X
  1254. X# Convert all the files in the current directory from unix to MS-DOS
  1255. X# line ending conventions.
  1256. X#
  1257. X# By Diomidis Spinellis
  1258. X#
  1259. Xopen(FILES, 'find . -print |');
  1260. Xwhile ($file = <FILES>) {
  1261. X    $file =^ s/[\n\r]//;
  1262. X    if (-f $file) {
  1263. X        if (-B $file) {
  1264. X            print STDERR "Skipping binary file $file\n";
  1265. X            next;
  1266. X        }
  1267. X        ($dev, $ino, $mode, $nlink, $uid, $gid, $rdev, $size, $atime, $mtime, $ctime,
  1268. X $blksize, $blocks) = stat($file);
  1269. X        open(IFILE, "$file");
  1270. X        open(OFILE, ">xl$$");
  1271. X        while (<IFILE>) {
  1272. X            print OFILE;
  1273. X        }
  1274. X        close(OFILE) || die "close xl$$: $!\n";
  1275. X        close(IFILE) || die "close $file: $!\n";
  1276. X        unlink($file) || die "unlink $file: $!\n";
  1277. X        rename("xl$$", $file) || die "rename(xl$$, $file): $!\n";
  1278. X        chmod($mode, $file) || die "chmod($mode, $file: $!\n";
  1279. X        utime($atime, $mtime, $file) || die "utime($atime, $mtime, $file): $!\n";
  1280. X    }
  1281. X}
  1282. !STUFFY!FUNK!
  1283. echo Extracting eg/changes
  1284. sed >eg/changes <<'!STUFFY!FUNK!' -e 's/X//'
  1285. X#!/usr/bin/perl -P
  1286. X
  1287. X# $Header: changes,v 4.0 91/03/20 01:08:56 lwall Locked $
  1288. X
  1289. X($dir, $days) = @ARGV;
  1290. X$dir = '/' if $dir eq '';
  1291. X$days = '14' if $days eq '';
  1292. X
  1293. X# Masscomps do things differently from Suns
  1294. X
  1295. X#if defined(mc300) || defined(mc500) || defined(mc700)
  1296. Xopen(Find, "find $dir -mtime -$days -print |") ||
  1297. X    die "changes: can't run find";
  1298. X#else
  1299. Xopen(Find, "find $dir \\( -fstype nfs -prune \\) -o -mtime -$days -ls |") ||
  1300. X    die "changes: can't run find";
  1301. X#endif
  1302. X
  1303. Xwhile (<Find>) {
  1304. X
  1305. X#if defined(mc300) || defined(mc500) || defined(mc700)
  1306. X    $x = `/bin/ls -ild $_`;
  1307. X    $_ = $x;
  1308. X    ($inode,$perm,$links,$owner,$group,$size,$month,$day,$time,$name)
  1309. X      = split(' ');
  1310. X#else
  1311. X    ($inode,$blocks,$perm,$links,$owner,$group,$size,$month,$day,$time,$name)
  1312. X      = split(' ');
  1313. X#endif
  1314. X
  1315. X    printf("%10s%3s %-8s %-8s%9s %3s %2s %s\n",
  1316. X        $perm,$links,$owner,$group,$size,$month,$day,$name);
  1317. X}
  1318. X
  1319. !STUFFY!FUNK!
  1320. echo Extracting t/op/regexp.t
  1321. sed >t/op/regexp.t <<'!STUFFY!FUNK!' -e 's/X//'
  1322. X#!./perl
  1323. X
  1324. X# $Header: regexp.t,v 4.0 91/03/20 01:54:22 lwall Locked $
  1325. X
  1326. Xopen(TESTS,'op/re_tests') || open(TESTS,'t/op/re_tests')
  1327. X    || die "Can't open re_tests";
  1328. Xwhile (<TESTS>) { }
  1329. X$numtests = $.;
  1330. Xclose(TESTS);
  1331. X
  1332. Xprint "1..$numtests\n";
  1333. Xopen(TESTS,'op/re_tests') || open(TESTS,'t/op/re_tests')
  1334. X    || die "Can't open re_tests";
  1335. Xwhile (<TESTS>) {
  1336. X    ($pat, $subject, $result, $repl, $expect) = split(/[\t\n]/,$_);
  1337. X    $input = join(':',$pat,$subject,$result,$repl,$expect);
  1338. X    eval "\$match = (\$subject =~ \$pat); \$got = \"$repl\";";
  1339. X    if ($result eq 'c') {
  1340. X    if ($@ ne '') {print "ok $.\n";} else {print "not ok $.\n";}
  1341. X    }
  1342. X    elsif ($result eq 'n') {
  1343. X    if (!$match) {print "ok $.\n";} else {print "not ok $. $input => $got\n";}
  1344. X    }
  1345. X    else {
  1346. X    if ($match && $got eq $expect) {
  1347. X        print "ok $.\n";
  1348. X    }
  1349. X    else {
  1350. X        print "not ok $. $input => $got\n";
  1351. X    }
  1352. X    }
  1353. X}
  1354. Xclose(TESTS);
  1355. !STUFFY!FUNK!
  1356. echo Extracting eg/myrup
  1357. sed >eg/myrup <<'!STUFFY!FUNK!' -e 's/X//'
  1358. X#!/usr/bin/perl
  1359. X
  1360. X# $Header: myrup,v 4.0 91/03/20 01:11:16 lwall Locked $
  1361. X
  1362. X# This was a customization of ruptime requested by someone here who wanted
  1363. X# to be able to find the least loaded machine easily.  It uses the
  1364. X# /etc/ghosts file that's defined for gsh and gcp to prune down the
  1365. X# number of entries to those hosts we have administrative control over.
  1366. X
  1367. Xprint "node    load (u)\n------- --------\n";
  1368. X
  1369. Xopen(ghosts,'/etc/ghosts') || die "Can't open /etc/ghosts: $!";
  1370. Xline: while (<ghosts>) {
  1371. X    next line if /^#/;
  1372. X    next line if /^$/;
  1373. X    next line if /=/;
  1374. X    ($host) = split;
  1375. X    $wanted{$host} = 1;
  1376. X}
  1377. X
  1378. Xopen(ruptime,'ruptime|') || die "Can't run ruptime: $!";
  1379. Xopen(sort,'|sort +1n');
  1380. X
  1381. Xwhile (<ruptime>) {
  1382. X    ($host,$upness,$foo,$users,$foo,$foo,$load) = split(/[\s,]+/);
  1383. X    if ($wanted{$host} && $upness eq 'up') {
  1384. X    printf sort "%s\t%s (%d)\n", $host, $load, $users;
  1385. X    }
  1386. X}
  1387. !STUFFY!FUNK!
  1388. echo Extracting eg/sysvipc/ipcmsg
  1389. sed >eg/sysvipc/ipcmsg <<'!STUFFY!FUNK!' -e 's/X//'
  1390. X#!/usr/bin/perl
  1391. Xeval 'exec /usr/bin/perl -S $0 ${1+"$@"}'
  1392. X    if 0;
  1393. X
  1394. Xrequire 'sys/ipc.ph';
  1395. Xrequire 'sys/msg.ph';
  1396. X
  1397. X$| = 1;
  1398. X
  1399. X$mode = shift;
  1400. Xdie "usage: ipcmsg {r|s}\n" unless $mode =~ /^[rs]$/;
  1401. X$send = ($mode eq "s");
  1402. X
  1403. X$id = msgget(0x1234, ($send ? 0 : &IPC_CREAT) | 0644);
  1404. Xdie "Can't get message queue: $!\n" unless defined($id);
  1405. Xprint "message queue id: $id\n";
  1406. X
  1407. Xif ($send) {
  1408. X    while (<STDIN>) {
  1409. X        chop;
  1410. X        unless (msgsnd($id, pack("LA*", $., $_), 0)) {
  1411. X            die "Can't send message: $!\n";
  1412. X        }
  1413. X    }
  1414. X}
  1415. Xelse {
  1416. X    $SIG{'INT'} = $SIG{'QUIT'} = "leave";
  1417. X    for (;;) {
  1418. X        unless (msgrcv($id, $_, 512, 0, 0)) {
  1419. X            die "Can't receive message: $!\n";
  1420. X        }
  1421. X        ($type, $message) = unpack("La*", $_);
  1422. X        printf "[%d] %s\n", $type, $message;
  1423. X    }
  1424. X}
  1425. X
  1426. X&leave;
  1427. X
  1428. Xsub leave {
  1429. X    if (!$send) {
  1430. X        $x = msgctl($id, &IPC_RMID, 0);
  1431. X        if (!defined($x) || $x < 0) {
  1432. X            die "Can't remove message queue: $!\n";
  1433. X        }
  1434. X    }
  1435. X    exit;
  1436. X}
  1437. !STUFFY!FUNK!
  1438. echo Extracting eg/sysvipc/ipcsem
  1439. sed >eg/sysvipc/ipcsem <<'!STUFFY!FUNK!' -e 's/X//'
  1440. X#!/usr/bin/perl
  1441. Xeval 'exec /usr/bin/perl -S $0 ${1+"$@"}'
  1442. X    if 0;
  1443. X
  1444. Xrequire 'sys/ipc.ph';
  1445. Xrequire 'sys/msg.ph';
  1446. X
  1447. X$| = 1;
  1448. X
  1449. X$mode = shift;
  1450. Xdie "usage: ipcmsg {r|s}\n" unless $mode =~ /^[rs]$/;
  1451. X$signal = ($mode eq "s");
  1452. X
  1453. X$id = semget(0x1234, 1, ($signal ? 0 : &IPC_CREAT) | 0644);
  1454. Xdie "Can't get semaphore: $!\n" unless defined($id);
  1455. Xprint "semaphore id: $id\n";
  1456. X
  1457. Xif ($signal) {
  1458. X    while (<STDIN>) {
  1459. X        print "Signalling\n";
  1460. X        unless (semop($id, 0, pack("sss", 0, 1, 0))) {
  1461. X            die "Can't signal semaphore: $!\n";
  1462. X        }
  1463. X    }
  1464. X}
  1465. Xelse {
  1466. X    $SIG{'INT'} = $SIG{'QUIT'} = "leave";
  1467. X    for (;;) {
  1468. X        unless (semop($id, 0, pack("sss", 0, -1, 0))) {
  1469. X            die "Can't wait for semaphore: $!\n";
  1470. X        }
  1471. X        print "Unblocked\n";
  1472. X    }
  1473. X}
  1474. X
  1475. X&leave;
  1476. X
  1477. Xsub leave {
  1478. X    if (!$signal) {
  1479. X        $x = semctl($id, 0, &IPC_RMID, 0);
  1480. X        if (!defined($x) || $x < 0) {
  1481. X            die "Can't remove semaphore: $!\n";
  1482. X        }
  1483. X    }
  1484. X    exit;
  1485. X}
  1486. !STUFFY!FUNK!
  1487. echo Extracting t/op/vec.t
  1488. sed >t/op/vec.t <<'!STUFFY!FUNK!' -e 's/X//'
  1489. X#!./perl
  1490. X
  1491. X# $Header: vec.t,v 4.0 91/03/20 01:55:28 lwall Locked $
  1492. X
  1493. Xprint "1..13\n";
  1494. X
  1495. Xprint vec($foo,0,1) == 0 ? "ok 1\n" : "not ok 1\n";
  1496. Xprint length($foo) == 0 ? "ok 2\n" : "not ok 2\n";
  1497. Xvec($foo,0,1) = 1;
  1498. Xprint length($foo) == 1 ? "ok 3\n" : "not ok 3\n";
  1499. Xprint ord($foo) == 1 ? "ok 4\n" : "not ok 4\n";
  1500. Xprint vec($foo,0,1) == 1 ? "ok 5\n" : "not ok 5\n";
  1501. X
  1502. Xprint vec($foo,20,1) == 0 ? "ok 6\n" : "not ok 6\n";
  1503. Xvec($foo,20,1) = 1;
  1504. Xprint vec($foo,20,1) == 1 ? "ok 7\n" : "not ok 7\n";
  1505. Xprint length($foo) == 3 ? "ok 8\n" : "not ok 8\n";
  1506. Xprint vec($foo,1,8) == 0 ? "ok 9\n" : "not ok 9\n";
  1507. Xvec($foo,1,8) = 0xf1;
  1508. Xprint vec($foo,1,8) == 0xf1 ? "ok 10\n" : "not ok 10\n";
  1509. Xprint ((ord(substr($foo,1,1)) & 255) == 0xf1 ? "ok 11\n" : "not ok 11\n");
  1510. Xprint vec($foo,2,4) == 1 ? "ok 12\n" : "not ok 12\n";
  1511. Xprint vec($foo,3,4) == 15 ? "ok 13\n" : "not ok 13\n";
  1512. X
  1513. !STUFFY!FUNK!
  1514. echo Extracting util.h
  1515. sed >util.h <<'!STUFFY!FUNK!' -e 's/X//'
  1516. X/* $Header: util.h,v 4.0 91/03/20 01:56:48 lwall Locked $
  1517. X *
  1518. X *    Copyright (c) 1989, Larry Wall
  1519. X *
  1520. X *    You may distribute under the terms of the GNU General Public License
  1521. X *    as specified in the README file that comes with the perl 3.0 kit.
  1522. X *
  1523. X * $Log:    util.h,v $
  1524. X * Revision 4.0  91/03/20  01:56:48  lwall
  1525. X * 4.0 baseline.
  1526. X * 
  1527. X */
  1528. X
  1529. XEXT int *screamfirst INIT(Null(int*));
  1530. XEXT int *screamnext INIT(Null(int*));
  1531. X
  1532. Xchar    *safemalloc();
  1533. Xchar    *saferealloc();
  1534. Xchar    *cpytill();
  1535. Xchar    *instr();
  1536. Xchar    *fbminstr();
  1537. Xchar    *screaminstr();
  1538. Xvoid    fbmcompile();
  1539. Xchar    *savestr();
  1540. Xvoid    setenv();
  1541. Xint    envix();
  1542. Xvoid    growstr();
  1543. Xchar    *ninstr();
  1544. Xchar    *rninstr();
  1545. Xchar    *nsavestr();
  1546. XFILE    *mypopen();
  1547. Xint    mypclose();
  1548. X#ifndef HAS_MEMCPY
  1549. X#ifndef HAS_BCOPY
  1550. Xchar    *bcopy();
  1551. X#endif
  1552. X#ifndef HAS_BZERO
  1553. Xchar    *bzero();
  1554. X#endif
  1555. X#endif
  1556. Xunsigned long scanoct();
  1557. Xunsigned long scanhex();
  1558. !STUFFY!FUNK!
  1559. echo Extracting t/op/range.t
  1560. sed >t/op/range.t <<'!STUFFY!FUNK!' -e 's/X//'
  1561. X#!./perl
  1562. X
  1563. X# $Header: range.t,v 4.0 91/03/20 01:54:11 lwall Locked $
  1564. X
  1565. Xprint "1..8\n";
  1566. X
  1567. Xprint join(':',1..5) eq '1:2:3:4:5' ? "ok 1\n" : "not ok 1\n";
  1568. X
  1569. X@foo = (1,2,3,4,5,6,7,8,9);
  1570. X@foo[2..4] = ('c','d','e');
  1571. X
  1572. Xprint join(':',@foo[$foo[0]..5]) eq '2:c:d:e:6' ? "ok 2\n" : "not ok 2\n";
  1573. X
  1574. X@bar[2..4] = ('c','d','e');
  1575. Xprint join(':',@bar[1..5]) eq ':c:d:e:' ? "ok 3\n" : "not ok 3\n";
  1576. X
  1577. X($a,@bcd[0..2],$e) = ('a','b','c','d','e');
  1578. Xprint join(':',$a,@bcd[0..2],$e) eq 'a:b:c:d:e' ? "ok 4\n" : "not ok 4\n";
  1579. X
  1580. X$x = 0;
  1581. Xfor (1..100) {
  1582. X    $x += $_;
  1583. X}
  1584. Xprint $x == 5050 ? "ok 5\n" : "not ok 5 $x\n";
  1585. X
  1586. X$x = 0;
  1587. Xfor ((100,2..99,1)) {
  1588. X    $x += $_;
  1589. X}
  1590. Xprint $x == 5050 ? "ok 6\n" : "not ok 6 $x\n";
  1591. X
  1592. X$x = join('','a'..'z');
  1593. Xprint $x eq 'abcdefghijklmnopqrstuvwxyz' ? "ok 7\n" : "not ok 7 $x\n";
  1594. X
  1595. X@x = 'A'..'ZZ';
  1596. Xprint @x == 27 * 26 ? "ok 8\n" : "not ok 8\n";
  1597. !STUFFY!FUNK!
  1598. echo Extracting form.h
  1599. sed >form.h <<'!STUFFY!FUNK!' -e 's/X//'
  1600. X/* $Header: form.h,v 4.0 91/03/20 01:19:37 lwall Locked $
  1601. X *
  1602. X *    Copyright (c) 1989, Larry Wall
  1603. X *
  1604. X *    You may distribute under the terms of the GNU General Public License
  1605. X *    as specified in the README file that comes with the perl 3.0 kit.
  1606. X *
  1607. X * $Log:    form.h,v $
  1608. X * Revision 4.0  91/03/20  01:19:37  lwall
  1609. X * 4.0 baseline.
  1610. X * 
  1611. X */
  1612. X
  1613. X#define F_NULL 0
  1614. X#define F_LEFT 1
  1615. X#define F_RIGHT 2
  1616. X#define F_CENTER 3
  1617. X#define F_LINES 4
  1618. X#define F_DECIMAL 5
  1619. X
  1620. Xstruct formcmd {
  1621. X    struct formcmd *f_next;
  1622. X    ARG *f_expr;
  1623. X    STR *f_unparsed;
  1624. X    line_t f_line;
  1625. X    char *f_pre;
  1626. X    short f_presize;
  1627. X    short f_size;
  1628. X    short f_decimals;
  1629. X    char f_type;
  1630. X    char f_flags;
  1631. X};
  1632. X
  1633. X#define FC_CHOP 1
  1634. X#define FC_NOBLANK 2
  1635. X#define FC_MORE 4
  1636. X#define FC_REPEAT 8
  1637. X#define FC_DP 16
  1638. X
  1639. X#define Nullfcmd Null(FCMD*)
  1640. X
  1641. XEXT char *chopset INIT(" \n-");
  1642. !STUFFY!FUNK!
  1643. echo Extracting x2p/util.h
  1644. sed >x2p/util.h <<'!STUFFY!FUNK!' -e 's/X//'
  1645. X/* $Header: util.h,v 4.0 91/03/20 01:58:29 lwall Locked $
  1646. X *
  1647. X *    Copyright (c) 1989, Larry Wall
  1648. X *
  1649. X *    You may distribute under the terms of the GNU General Public License
  1650. X *    as specified in the README file that comes with the perl 3.0 kit.
  1651. X *
  1652. X * $Log:    util.h,v $
  1653. X * Revision 4.0  91/03/20  01:58:29  lwall
  1654. X * 4.0 baseline.
  1655. X * 
  1656. X */
  1657. X
  1658. X/* is the string for makedir a directory name or a filename? */
  1659. X
  1660. X#define MD_DIR 0
  1661. X#define MD_FILE 1
  1662. X
  1663. Xvoid    util_init();
  1664. Xint    doshell();
  1665. Xchar    *safemalloc();
  1666. Xchar    *saferealloc();
  1667. Xchar    *safecpy();
  1668. Xchar    *safecat();
  1669. Xchar    *cpytill();
  1670. Xchar    *cpy2();
  1671. Xchar    *instr();
  1672. X#ifdef SETUIDGID
  1673. X    int        eaccess();
  1674. X#endif
  1675. Xchar    *getwd();
  1676. Xvoid    cat();
  1677. Xvoid    prexit();
  1678. Xchar    *get_a_line();
  1679. Xchar    *savestr();
  1680. Xint    makedir();
  1681. Xvoid    setenv();
  1682. Xint    envix();
  1683. Xvoid    notincl();
  1684. Xchar    *getval();
  1685. Xvoid    growstr();
  1686. Xvoid    setdef();
  1687. !STUFFY!FUNK!
  1688. echo Extracting lib/dumpvar.pl
  1689. sed >lib/dumpvar.pl <<'!STUFFY!FUNK!' -e 's/X//'
  1690. Xpackage dumpvar;
  1691. X
  1692. X# translate control chars to ^X - Randal Schwartz
  1693. Xsub unctrl {
  1694. X    local($_) = @_;
  1695. X    s/([\001-\037\177])/'^'.pack('c',ord($1)^64)/eg;
  1696. X    $_;
  1697. X}
  1698. Xsub main'dumpvar {
  1699. X    ($package,@vars) = @_;
  1700. X    local(*stab) = eval("*_$package");
  1701. X    while (($key,$val) = each(%stab)) {
  1702. X    {
  1703. X        next if @vars && !grep($key eq $_,@vars);
  1704. X        local(*entry) = $val;
  1705. X        if (defined $entry) {
  1706. X        print "\$$key = '",&unctrl($entry),"'\n";
  1707. X        }
  1708. X        if (defined @entry) {
  1709. X        print "\@$key = (\n";
  1710. X        foreach $num ($[ .. $#entry) {
  1711. X            print "  $num\t'",&unctrl($entry[$num]),"'\n";
  1712. X        }
  1713. X        print ")\n";
  1714. X        }
  1715. X        if ($key ne "_$package" && $key ne "_DB" && defined %entry) {
  1716. X        print "\%$key = (\n";
  1717. X        foreach $key (sort keys(%entry)) {
  1718. X            print "  $key\t'",&unctrl($entry{$key}),"'\n";
  1719. X        }
  1720. X        print ")\n";
  1721. X        }
  1722. X    }
  1723. X    }
  1724. X}
  1725. X
  1726. X1;
  1727. !STUFFY!FUNK!
  1728. echo Extracting eg/g/ghosts
  1729. sed >eg/g/ghosts <<'!STUFFY!FUNK!' -e 's/X//'
  1730. X# This first section gives alternate sets defined in terms of the sets given
  1731. X# by the second section.  The order is important--all references must be
  1732. X# forward references.
  1733. X
  1734. XNnd=sun-nd
  1735. Xall=sun+mc+vax
  1736. Xbaseline=sun+mc
  1737. Xsun=sun2+sun3
  1738. Xvax=750+8600
  1739. Xpep=manny+moe+jack
  1740. X
  1741. X# This second section defines the basic sets.  Each host should have a line
  1742. X# that specifies which sets it is a member of.  Extra sets should be separated
  1743. X# by white space.  (The first section isn't strictly necessary, since all sets
  1744. X# could be defined in the second section, but then it wouldn't be so readable.)
  1745. X
  1746. Xbasvax    8600    src
  1747. Xcdb0    sun3        sys
  1748. Xcdb1    sun3        sys
  1749. Xcdb2    sun3        sys
  1750. Xchief    sun3    src
  1751. Xtis0    sun3
  1752. Xmanny    sun3        sys
  1753. Xmoe    sun3        sys
  1754. Xjack    sun3        sys
  1755. Xdisney    sun3        sys
  1756. Xhuey    sun3        nd
  1757. Xdewey    sun3        nd
  1758. Xlouie    sun3        nd
  1759. Xbizet    sun2    src    sys
  1760. Xgif0    mc    src
  1761. Xmc0    mc
  1762. Xdtv0    mc
  1763. !STUFFY!FUNK!
  1764. echo Extracting t/comp/multiline.t
  1765. sed >t/comp/multiline.t <<'!STUFFY!FUNK!' -e 's/X//'
  1766. X#!./perl
  1767. X
  1768. X# $Header: multiline.t,v 4.0 91/03/20 01:50:15 lwall Locked $
  1769. X
  1770. Xprint "1..5\n";
  1771. X
  1772. Xopen(try,'>Comp.try') || (die "Can't open temp file.");
  1773. X
  1774. X$x = 'now is the time
  1775. Xfor all good men
  1776. Xto come to.
  1777. X';
  1778. X
  1779. X$y = 'now is the time' . "\n" .
  1780. X'for all good men' . "\n" .
  1781. X'to come to.' . "\n";
  1782. X
  1783. Xif ($x eq $y) {print "ok 1\n";} else {print "not ok 1\n";}
  1784. X
  1785. Xprint try $x;
  1786. Xclose try;
  1787. X
  1788. Xopen(try,'Comp.try') || (die "Can't reopen temp file.");
  1789. X$count = 0;
  1790. X$z = '';
  1791. Xwhile (<try>) {
  1792. X    $z .= $_;
  1793. X    $count = $count + 1;
  1794. X}
  1795. X
  1796. Xif ($z eq $y) {print "ok 2\n";} else {print "not ok 2\n";}
  1797. X
  1798. Xif ($count == 3) {print "ok 3\n";} else {print "not ok 3\n";}
  1799. X
  1800. X$_ = `cat Comp.try`;
  1801. X
  1802. Xif (/.*\n.*\n.*\n$/) {print "ok 4\n";} else {print "not ok 4\n";}
  1803. X`/bin/rm -f Comp.try`;
  1804. X
  1805. Xif ($_ eq $y) {print "ok 5\n";} else {print "not ok 5\n";}
  1806. !STUFFY!FUNK!
  1807. echo Extracting t/op/local.t
  1808. sed >t/op/local.t <<'!STUFFY!FUNK!' -e 's/X//'
  1809. X#!./perl
  1810. X
  1811. X# $Header: local.t,v 4.0 91/03/20 01:53:29 lwall Locked $
  1812. X
  1813. Xprint "1..20\n";
  1814. X
  1815. Xsub foo {
  1816. X    local($a, $b) = @_;
  1817. X    local($c, $d);
  1818. X    $c = "ok 3\n";
  1819. X    $d = "ok 4\n";
  1820. X    { local($a,$c) = ("ok 9\n", "ok 10\n"); ($x, $y) = ($a, $c); }
  1821. X    print $a, $b;
  1822. X    $c . $d;
  1823. X}
  1824. X
  1825. X$a = "ok 5\n";
  1826. X$b = "ok 6\n";
  1827. X$c = "ok 7\n";
  1828. X$d = "ok 8\n";
  1829. X
  1830. Xprint do foo("ok 1\n","ok 2\n");
  1831. X
  1832. Xprint $a,$b,$c,$d,$x,$y;
  1833. X
  1834. X# same thing, only with arrays and associative arrays
  1835. X
  1836. Xsub foo2 {
  1837. X    local($a, @b) = @_;
  1838. X    local(@c, %d);
  1839. X    @c = "ok 13\n";
  1840. X    $d{''} = "ok 14\n";
  1841. X    { local($a,@c) = ("ok 19\n", "ok 20\n"); ($x, $y) = ($a, @c); }
  1842. X    print $a, @b;
  1843. X    $c[0] . $d{''};
  1844. X}
  1845. X
  1846. X$a = "ok 15\n";
  1847. X@b = "ok 16\n";
  1848. X@c = "ok 17\n";
  1849. X$d{''} = "ok 18\n";
  1850. X
  1851. Xprint do foo2("ok 11\n","ok 12\n");
  1852. X
  1853. Xprint $a,@b,@c,%d,$x,$y;
  1854. !STUFFY!FUNK!
  1855. echo Extracting eg/van/empty
  1856. sed >eg/van/empty <<'!STUFFY!FUNK!' -e 's/X//'
  1857. X#!/usr/bin/perl
  1858. X
  1859. X# $Header: empty,v 4.0 91/03/20 01:15:25 lwall Locked $
  1860. X
  1861. X# This script empties a trashcan.
  1862. X
  1863. X$recursive = shift if $ARGV[0] eq '-r';
  1864. X
  1865. X@ARGV = '.' if $#ARGV < 0;
  1866. X
  1867. Xchop($pwd = `pwd`);
  1868. X
  1869. Xdir: foreach $dir (@ARGV) {
  1870. X    unless (chdir $dir) {
  1871. X    print stderr "Can't find directory $dir: $!\n";
  1872. X    next dir;
  1873. X    }
  1874. X    if ($recursive) {
  1875. X    do cmd('find . -name .deleted -exec /bin/rm -rf {} ;');
  1876. X    }
  1877. X    else {
  1878. X    if (-d '.deleted') {
  1879. X        do cmd('rm -rf .deleted');
  1880. X    }
  1881. X    else {
  1882. X        if ($dir eq '.' && $pwd =~ m|/\.deleted$|) {
  1883. X        chdir '..';
  1884. X        do cmd('rm -rf .deleted');
  1885. X        }
  1886. X        else {
  1887. X        print stderr "No trashcan found in directory $dir\n";
  1888. X        }
  1889. X    }
  1890. X    }
  1891. X}
  1892. Xcontinue {
  1893. X    chdir $pwd;
  1894. X}
  1895. X
  1896. X# force direct execution with no shell
  1897. X
  1898. Xsub cmd {
  1899. X    system split(' ',join(' ',@_));
  1900. X}
  1901. X
  1902. !STUFFY!FUNK!
  1903. echo Extracting eg/travesty
  1904. sed >eg/travesty <<'!STUFFY!FUNK!' -e 's/X//'
  1905. X#!/usr/bin/perl
  1906. X
  1907. Xwhile (<>) {
  1908. X    next if /^\./;
  1909. X    next if /^From / .. /^$/;
  1910. X    next if /^Path: / .. /^$/;
  1911. X    s/^\W+//;
  1912. X    push(@ary,split(' '));
  1913. X    while ($#ary > 1) {
  1914. X    $a = $p;
  1915. X    $p = $n;
  1916. X    $w = shift(@ary);
  1917. X    $n = $num{$w};
  1918. X    if ($n eq '') {
  1919. X        push(@word,$w);
  1920. X        $n = pack('S',$#word);
  1921. X        $num{$w} = $n;
  1922. X    }
  1923. X    $lookup{$a . $p} .= $n;
  1924. X    }
  1925. X}
  1926. X
  1927. Xfor (;;) {
  1928. X    $n = $lookup{$a . $p};
  1929. X    ($foo,$n) = each(lookup) if $n eq '';
  1930. X    $n = substr($n,int(rand(length($n))) & 0177776,2);
  1931. X    $a = $p;
  1932. X    $p = $n;
  1933. X    ($w) = unpack('S',$n);
  1934. X    $w = $word[$w];
  1935. X    $col += length($w) + 1;
  1936. X    if ($col >= 65) {
  1937. X    $col = 0;
  1938. X    print "\n";
  1939. X    }
  1940. X    else {
  1941. X    print ' ';
  1942. X    }
  1943. X    print $w;
  1944. X    if ($w =~ /\.$/) {
  1945. X    if (rand() < .1) {
  1946. X        print "\n";
  1947. X        $col = 80;
  1948. X    }
  1949. X    }
  1950. X}
  1951. !STUFFY!FUNK!
  1952. echo Extracting msdos/Wishlist.dds
  1953. sed >msdos/Wishlist.dds <<'!STUFFY!FUNK!' -e 's/X//'
  1954. XPerl in general:
  1955. XAdd ftw or find?
  1956. XAdd a parsing mechanism (user specifies parse tree, perl parses).
  1957. XArbitrary precision arithmetic.
  1958. XFile calculus (e.g. file1 = file2 + file3, file1 =^ s/foo/bar/g etc.)
  1959. X
  1960. XMS-DOS version of Perl:
  1961. XAdd interface to treat dBase files as associative arrays.
  1962. XAdd int86x function.
  1963. XHandle the C preprocessor.
  1964. XProvide real pipes by switching the processes. (difficult)
  1965. XProvide a list of ioctl codes.
  1966. XCheck the ioctl errno handling.
  1967. XI can't find an easy way in Perl to pass a number as the first argument
  1968. X  to ioctl.  This is needed for some functions of ioctl.  Either hack
  1969. X  ioctl, or change perl to ioctl interface.  Another solution would be
  1970. X  a perl pseudo array containing the filehandles indexed by fd.
  1971. !STUFFY!FUNK!
  1972. echo Extracting h2pl/mksizes
  1973. sed >h2pl/mksizes <<'!STUFFY!FUNK!' -e 's/X//'
  1974. X#!/usr/local/bin/perl
  1975. X
  1976. X($iam = $0) =~ s%.*/%%;
  1977. X$tmp = "$iam.$$";
  1978. Xopen (CODE,">$tmp.c") || die "$iam: cannot create $tmp.c: $!\n";
  1979. X
  1980. X$mask = q/printf ("$sizeof{'%s'} = %d;\n"/; 
  1981. X
  1982. X# write C program
  1983. Xselect(CODE);
  1984. X
  1985. Xprint <<EO_C_PROGRAM;
  1986. X#include <sys/param.h>
  1987. X#include <sys/types.h>
  1988. X#include <sys/socket.h>
  1989. X#include <net/if_arp.h>
  1990. X#include <net/if.h>
  1991. X#include <net/route.h>
  1992. X#include <sys/ioctl.h>
  1993. X
  1994. Xmain() {
  1995. XEO_C_PROGRAM
  1996. X
  1997. Xwhile ( <> ) {
  1998. X    chop;
  1999. X    printf "\t%s, \n\t\t\"%s\", sizeof(%s));\n", $mask, $_,$_;
  2000. X}
  2001. X
  2002. Xprint "\n}\n";
  2003. X
  2004. Xclose CODE;
  2005. X
  2006. X# compile C program
  2007. X
  2008. Xselect(STDOUT);
  2009. X
  2010. Xsystem "cc $tmp.c -o $tmp";
  2011. Xdie "couldn't compile $tmp.c" if $?;
  2012. Xsystem "./$tmp";        
  2013. Xdie "couldn't run $tmp" if $?;
  2014. X
  2015. Xunlink "$tmp.c", $tmp;
  2016. !STUFFY!FUNK!
  2017. echo Extracting eg/scan/scan_passwd
  2018. sed >eg/scan/scan_passwd <<'!STUFFY!FUNK!' -e 's/X//'
  2019. X#!/usr/bin/perl
  2020. X
  2021. X# $Header: scan_passwd,v 4.0 91/03/20 01:13:18 lwall Locked $
  2022. X
  2023. X# This scans passwd file for security holes.
  2024. X
  2025. Xopen(Pass,'/etc/passwd') || die "Can't open passwd file: $!\n";
  2026. X# $dotriv = (`date` =~ /^Mon/);
  2027. X$dotriv = 1;
  2028. X
  2029. Xwhile (<Pass>) {
  2030. X    ($login,$pass,$uid,$gid,$gcos,$home,$shell) = split(/:/);
  2031. X    if ($shell eq '') {
  2032. X    print "Short: $_";
  2033. X    }
  2034. X    next if /^[+]/;
  2035. X    if ($pass eq '') {
  2036. X    if (index(":sync:lpq:+:", ":$login:") < 0) {
  2037. X        print "No pass: $login\t$gcos\n";
  2038. X    }
  2039. X    }
  2040. X    elsif ($dotriv && crypt($login,substr($pass,0,2)) eq $pass) {
  2041. X    print "Trivial: $login\t$gcos\n";
  2042. X    }
  2043. X    if ($uid == 0) {
  2044. X    if ($login !~ /^.?root$/ && $pass ne '*') {
  2045. X        print "Extra root: $_";
  2046. X    }
  2047. X    }
  2048. X}
  2049. !STUFFY!FUNK!
  2050. echo Extracting h2pl/mkvars
  2051. sed >h2pl/mkvars <<'!STUFFY!FUNK!' -e 's/X//'
  2052. X#!/usr/bin/perl
  2053. X
  2054. Xrequire 'sizeof.ph';
  2055. X
  2056. X$LIB = '/usr/local/lib/perl';
  2057. X
  2058. Xforeach $include (@ARGV) {
  2059. X    printf STDERR "including %s\n", $include;
  2060. X    do $include;
  2061. X    warn "sourcing $include: $@\n" if ($@);
  2062. X    if (!open (INCLUDE,"$LIB/$include")) {
  2063. X    warn "can't open $LIB/$include: $!\n"; 
  2064. X    next; 
  2065. X    } 
  2066. X    while (<INCLUDE>) {
  2067. X    chop;
  2068. X    if (/^\s*eval\s+'sub\s+(\w+)\s.*[^{]$/ || /^\s*sub\s+(\w+)\s.*[^{]$/) {
  2069. X        $var = $1;
  2070. X        $val = eval "&$var;";
  2071. X        if ($@) {
  2072. X        warn "$@: $_";
  2073. X        print <<EOT
  2074. Xwarn "\$$var isn't correctly set" if defined \$_main{'$var'};
  2075. XEOT
  2076. X        next;
  2077. X        } 
  2078. X        ( $nval = sprintf ("%x",$val ) ) =~ tr/a-z/A-Z/;
  2079. X        printf "\$%s = 0x%s;\n", $var, $nval;
  2080. X    } 
  2081. X    }
  2082. X} 
  2083. !STUFFY!FUNK!
  2084. echo Extracting hints/uts.sh
  2085. sed >hints/uts.sh <<'!STUFFY!FUNK!' -e 's/X//'
  2086. Xccflags="$ccflags -DCRIPPLED_CC -g"
  2087. Xd_lstat=$undef
  2088. !STUFFY!FUNK!
  2089. echo " "
  2090. echo "End of kit 35 (of 36)"
  2091. cat /dev/null >kit35isdone
  2092. run=''
  2093. config=''
  2094. for iskit in 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36; do
  2095.     if test -f kit${iskit}isdone; then
  2096.     run="$run $iskit"
  2097.     else
  2098.     todo="$todo $iskit"
  2099.     fi
  2100. done
  2101. case $todo in
  2102.     '')
  2103.     echo "You have run all your kits.  Please read README and then type Configure."
  2104.     for combo in *:AA; do
  2105.         if test -f "$combo"; then
  2106.         realfile=`basename $combo :AA`
  2107.         cat $realfile:[A-Z][A-Z] >$realfile
  2108.         rm -rf $realfile:[A-Z][A-Z]
  2109.         fi
  2110.     done
  2111.     rm -rf kit*isdone
  2112.     chmod 755 Configure
  2113.     ;;
  2114.     *)  echo "You have run$run."
  2115.     echo "You still need to run$todo."
  2116.     ;;
  2117. esac
  2118. : Someone might mail this, so...
  2119. exit
  2120.  
  2121. exit 0 # Just in case...
  2122. -- 
  2123. Kent Landfield                   INTERNET: kent@sparky.IMD.Sterling.COM
  2124. Sterling Software, IMD           UUCP:     uunet!sparky!kent
  2125. Phone:    (402) 291-8300         FAX:      (402) 291-4362
  2126. Please send comp.sources.misc-related mail to kent@uunet.uu.net.
  2127.