home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1994 October / usenetsourcesnewsgroupsinfomagicoctober1994disk2.iso / misc / volume18 / perl / part34 < prev    next >
Internet Message Format  |  1991-04-20  |  51KB
  1. From: lwall@netlabs.com (Larry Wall)
  2. Newsgroups: comp.sources.misc
  3. Subject: v18i052:  perl - The perl programming language, Part34/36
  4. Message-ID: <1991Apr19.014951.5142@sparky.IMD.Sterling.COM>
  5. Date: 19 Apr 91 01:49:51 GMT
  6. Approved: kent@sparky.imd.sterling.com
  7. X-Checksum-Snefru: 9ec7af2a 039d76e1 a016c771 32513094
  8.  
  9. Submitted-by: Larry Wall <lwall@netlabs.com>
  10. Posting-number: Volume 18, Issue 52
  11. Archive-name: perl/part34
  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 34 (of 36).  If kit 34 is complete, the line"
  21. echo '"'"End of kit 34 (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/van h2pl h2pl/eg h2pl/eg/sys lib msdos os2 os2/eg t t/comp t/op usub x2p 2>/dev/null
  25. echo Extracting os2/dir.h
  26. sed >os2/dir.h <<'!STUFFY!FUNK!' -e 's/X//'
  27. X/*
  28. X * @(#) dir.h 1.4 87/11/06   Public Domain.
  29. X *
  30. X *  A public domain implementation of BSD directory routines for
  31. X *  MS-DOS.  Written by Michael Rendell ({uunet,utai}michael@garfield),
  32. X *  August 1987
  33. X *
  34. X *  Enhanced and ported to OS/2 by Kai Uwe Rommel; added scandir() prototype
  35. X *  December 1989, February 1990
  36. X *  Change of MAXPATHLEN for HPFS, October 1990
  37. X */
  38. X
  39. X
  40. X#define MAXNAMLEN  256
  41. X#define MAXPATHLEN 256
  42. X
  43. X#define A_RONLY    0x01
  44. X#define A_HIDDEN   0x02
  45. X#define A_SYSTEM   0x04
  46. X#define A_LABEL    0x08
  47. X#define A_DIR      0x10
  48. X#define A_ARCHIVE  0x20
  49. X
  50. X
  51. Xstruct direct
  52. X{
  53. X  ino_t    d_ino;                   /* a bit of a farce */
  54. X  int      d_reclen;                /* more farce */
  55. X  int      d_namlen;                /* length of d_name */
  56. X  char     d_name[MAXNAMLEN + 1];   /* null terminated */
  57. X  /* nonstandard fields */
  58. X  long     d_size;                  /* size in bytes */
  59. X  unsigned d_mode;                  /* DOS or OS/2 file attributes */
  60. X  unsigned d_time;
  61. X  unsigned d_date;
  62. X};
  63. X
  64. X/* The fields d_size and d_mode are extensions by me (Kai Uwe Rommel).
  65. X * The find_first and find_next calls deliver this data without any extra cost.
  66. X * If this data is needed, these fields save a lot of extra calls to stat()
  67. X * (each stat() again performs a find_first call !).
  68. X */
  69. X
  70. Xstruct _dircontents
  71. X{
  72. X  char *_d_entry;
  73. X  long _d_size;
  74. X  unsigned _d_mode, _d_time, _d_date;
  75. X  struct _dircontents *_d_next;
  76. X};
  77. X
  78. Xtypedef struct _dirdesc
  79. X{
  80. X  int  dd_id;                   /* uniquely identify each open directory */
  81. X  long dd_loc;                  /* where we are in directory entry is this */
  82. X  struct _dircontents *dd_contents;   /* pointer to contents of dir */
  83. X  struct _dircontents *dd_cp;         /* pointer to current position */
  84. X}
  85. XDIR;
  86. X
  87. X
  88. Xextern int attributes;
  89. X
  90. Xextern DIR *opendir(char *);
  91. Xextern struct direct *readdir(DIR *);
  92. Xextern void seekdir(DIR *, long);
  93. Xextern long telldir(DIR *);
  94. Xextern void closedir(DIR *);
  95. X#define rewinddir(dirp) seekdir(dirp, 0L)
  96. X
  97. Xextern int scandir(char *, struct direct ***,
  98. X                   int (*)(struct direct *),
  99. X                   int (*)(struct direct *, struct direct *));
  100. X
  101. Xextern int getfmode(char *);
  102. Xextern int setfmode(char *, unsigned);
  103. !STUFFY!FUNK!
  104. echo Extracting os2/eg/os2.pl
  105. sed >os2/eg/os2.pl <<'!STUFFY!FUNK!' -e 's/X//'
  106. Xextproc C:\binp\misc\perl.exe -S
  107. X#!perl
  108. X
  109. X# os2.pl:  Demonstrates the OS/2 system calls and shows off some of the
  110. X# features in common with the UNIX version.
  111. X
  112. Xdo "syscalls.pl" || die "Cannot load syscalls.pl ($!)";
  113. X
  114. X# OS/2 version number.
  115. X
  116. X    $version = "  "; syscall($OS2_GetVersion,$version); 
  117. X    ($minor, $major) = unpack("CC", $version);
  118. X    print "You are using OS/2 version ", int($major/10), 
  119. X            ".", int($minor/10), "\n\n";
  120. X 
  121. X# Process ID.
  122. X    print "This process ID is $$ and its parent's ID is ", 
  123. X        getppid(), "\n\n";
  124. X
  125. X# Priority.
  126. X
  127. X    printf "Current priority is %x\n", getpriority(0,0);
  128. X    print "Changing priority by +5\n";
  129. X    print "Failed!\n" unless setpriority(0,0,+5);
  130. X    printf "Priority is now %x\n\n", getpriority(0,0);
  131. X
  132. X# Beep.
  133. X    print "Here is an A440.\n\n";
  134. X    syscall($OS2_Beep,440,50);
  135. X
  136. X# Pipes.  Unlike MS-DOS, OS/2 supports true asynchronous pipes.
  137. X    open(ROT13, '|perl -pe y/a-zA-Z/n-za-mN-ZA-M/') || die;
  138. X    select(ROT13); $|=1; select(STDOUT);
  139. X    print "Type two lines of stuff, and I'll ROT13 it while you wait.\n".
  140. X          "If you type fast, you might be able to type both of your\n".
  141. X          "lines before I get a chance to translate the first line.\n";
  142. X    $_ = <STDIN>; print ROT13 $_;
  143. X    $_ = <STDIN>; print ROT13 $_;
  144. X    close(ROT13);
  145. X    print "Thanks.\n\n";
  146. X
  147. X# Inspecting the disks.
  148. X    print "Let's look at the disks you have installed...\n\n";
  149. X
  150. X    $x = "\0\0";
  151. X    syscall($OS2_Config, $x, 2);
  152. X    print "You have ", unpack("S", $x), " floppy disks,\n";
  153. X
  154. X    $x = "  ";
  155. X    syscall($OS2_PhysicalDisk, 1, $x, 2, 0, 0);
  156. X    ($numdisks) = unpack("S", $x);
  157. X
  158. X    print "and $numdisks partitionable disks.\n\n";
  159. X    for ($i = 1; $i <= $numdisks; $i++) {
  160. X        $disk = $i . ":";
  161. X        $handle = "  ";
  162. X        syscall($OS2_PhysicalDisk, 2, $handle, 2, $disk, 3);
  163. X        ($numhandle) = unpack("S", $handle);
  164. X        $zero = pack("C", 0);
  165. X        $parmblock = " " x 16;
  166. X        syscall($OS2_IOCtl, $parmblock, $zero, 0x63, 9, $numhandle);
  167. X        ($x, $cylinders, $heads, $sect) = unpack("SSSS", $parmblock);
  168. X        print "Hard drive #$i:\n";
  169. X        print "   cylinders: $cylinders\n";
  170. X        print "       heads: $heads\n";
  171. X        print "    sect/trk: $sect\n";
  172. X        syscall($OS2_PhysicalDisk, 3, 0, 0, $handle, 2);
  173. X    }
  174. X
  175. X# I won't bother with the other stuff.  You get the idea.
  176. X
  177. !STUFFY!FUNK!
  178. echo Extracting t/op/write.t
  179. sed >t/op/write.t <<'!STUFFY!FUNK!' -e 's/X//'
  180. X#!./perl
  181. X
  182. X# $Header: write.t,v 4.0 91/03/20 01:55:34 lwall Locked $
  183. X
  184. Xprint "1..3\n";
  185. X
  186. Xformat OUT =
  187. Xthe quick brown @<<
  188. X$fox
  189. Xjumped
  190. X@*
  191. X$multiline
  192. X^<<<<<<<<<
  193. X$foo
  194. X^<<<<<<<<<
  195. X$foo
  196. X^<<<<<<...
  197. X$foo
  198. Xnow @<<the@>>>> for all@|||||men to come @<<<<
  199. X'i' . 's', "time\n", $good, 'to'
  200. X.
  201. X
  202. Xopen(OUT, '>Op.write.tmp') || die "Can't create Op.write.tmp";
  203. X
  204. X$fox = 'foxiness';
  205. X$good = 'good';
  206. X$multiline = "forescore\nand\nseven years\n";
  207. X$foo = 'when in the course of human events it becomes necessary';
  208. Xwrite(OUT);
  209. Xclose OUT;
  210. X
  211. X$right =
  212. X"the quick brown fox
  213. Xjumped
  214. Xforescore
  215. Xand
  216. Xseven years
  217. Xwhen in
  218. Xthe course
  219. Xof huma...
  220. Xnow is the time for all good men to come to\n";
  221. X
  222. Xif (`cat Op.write.tmp` eq $right)
  223. X    { print "ok 1\n"; unlink 'Op.write.tmp'; }
  224. Xelse
  225. X    { print "not ok 1\n"; }
  226. X
  227. Xformat OUT2 =
  228. Xthe quick brown @<<
  229. X$fox
  230. Xjumped
  231. X@*
  232. X$multiline
  233. X^<<<<<<<<< ~~
  234. X$foo
  235. Xnow @<<the@>>>> for all@|||||men to come @<<<<
  236. X'i' . 's', "time\n", $good, 'to'
  237. X.
  238. X
  239. Xopen(OUT2, '>Op.write.tmp') || die "Can't create Op.write.tmp";
  240. X
  241. X$fox = 'foxiness';
  242. X$good = 'good';
  243. X$multiline = "forescore\nand\nseven years\n";
  244. X$foo = 'when in the course of human events it becomes necessary';
  245. Xwrite(OUT2);
  246. Xclose OUT2;
  247. X
  248. X$right =
  249. X"the quick brown fox
  250. Xjumped
  251. Xforescore
  252. Xand
  253. Xseven years
  254. Xwhen in
  255. Xthe course
  256. Xof human
  257. Xevents it
  258. Xbecomes
  259. Xnecessary
  260. Xnow is the time for all good men to come to\n";
  261. X
  262. Xif (`cat Op.write.tmp` eq $right)
  263. X    { print "ok 2\n"; unlink 'Op.write.tmp'; }
  264. Xelse
  265. X    { print "not ok 2\n"; }
  266. X
  267. Xeval <<'EOFORMAT';
  268. Xformat OUT2 =
  269. Xthe brown quick @<<
  270. X$fox
  271. Xjumped
  272. X@*
  273. X$multiline
  274. X^<<<<<<<<< ~~
  275. X$foo
  276. Xnow @<<the@>>>> for all@|||||men to come @<<<<
  277. X'i' . 's', "time\n", $good, 'to'
  278. X.
  279. XEOFORMAT
  280. X
  281. Xopen(OUT2, '>Op.write.tmp') || die "Can't create Op.write.tmp";
  282. X
  283. X$fox = 'foxiness';
  284. X$good = 'good';
  285. X$multiline = "forescore\nand\nseven years\n";
  286. X$foo = 'when in the course of human events it becomes necessary';
  287. Xwrite(OUT2);
  288. Xclose OUT2;
  289. X
  290. X$right =
  291. X"the brown quick fox
  292. Xjumped
  293. Xforescore
  294. Xand
  295. Xseven years
  296. Xwhen in
  297. Xthe course
  298. Xof human
  299. Xevents it
  300. Xbecomes
  301. Xnecessary
  302. Xnow is the time for all good men to come to\n";
  303. X
  304. Xif (`cat Op.write.tmp` eq $right)
  305. X    { print "ok 3\n"; unlink 'Op.write.tmp'; }
  306. Xelse
  307. X    { print "not ok 3\n"; }
  308. X
  309. !STUFFY!FUNK!
  310. echo Extracting lib/complete.pl
  311. sed >lib/complete.pl <<'!STUFFY!FUNK!' -e 's/X//'
  312. X;#
  313. X;#    @(#)complete.pl    1.0 (sun!waynet) 11/11/88
  314. X;#
  315. X;# Author: Wayne Thompson
  316. X;#
  317. X;# Description:
  318. X;#     This routine provides word completion.
  319. X;#     (TAB) attempts word completion.
  320. X;#     (^D)  prints completion list.
  321. X;#    (These may be changed by setting $Complete'complete, etc.)
  322. X;#
  323. X;# Diagnostics:
  324. X;#     Bell when word completion fails.
  325. X;#
  326. X;# Dependencies:
  327. X;#     The tty driver is put into raw mode.
  328. X;#
  329. X;# Bugs:
  330. X;#
  331. X;# Usage:
  332. X;#     $input = do Complete('prompt_string', @completion_list);
  333. X;#
  334. X
  335. XCONFIG: {
  336. X    package Complete;
  337. X
  338. X    $complete =    "\004";
  339. X    $kill =    "\025";
  340. X    $erase1 =    "\177";
  341. X    $erase2 =    "\010";
  342. X}
  343. X
  344. Xsub Complete {
  345. X    package Complete;
  346. X
  347. X    local ($prompt) = shift (@_);
  348. X    local ($c, $cmp, $l, $r, $ret, $return, $test);
  349. X    @_cmp_lst = sort @_;
  350. X    local($[) = 0;
  351. X    system 'stty raw -echo';
  352. X    loop: {
  353. X    print $prompt, $return;
  354. X    while (($c = getc(stdin)) ne "\r") {
  355. X        if ($c eq "\t") {            # (TAB) attempt completion
  356. X        @_match = ();
  357. X        foreach $cmp (@_cmp_lst) {
  358. X            push (@_match, $cmp) if $cmp =~ /^$return/;
  359. X        }
  360. X                $test = $_match[0];
  361. X                $l = length ($test);
  362. X        unless ($#_match == 0) {
  363. X                    shift (@_match);
  364. X                    foreach $cmp (@_match) {
  365. X                        until (substr ($cmp, 0, $l) eq substr ($test, 0, $l)) {
  366. X                            $l--;
  367. X                        }
  368. X                    }
  369. X                    print "\007";
  370. X                }
  371. X                print $test = substr ($test, $r, $l - $r);
  372. X                $r = length ($return .= $test);
  373. X        }
  374. X        elsif ($c eq $complete) {        # (^D) completion list
  375. X        print "\r\n";
  376. X        foreach $cmp (@_cmp_lst) {
  377. X            print "$cmp\r\n" if $cmp =~ /^$return/;
  378. X        }
  379. X        redo loop;
  380. X        }
  381. X            elsif ($c eq $kill && $r) {    # (^U) kill
  382. X                $return = '';
  383. X                $r = 0;
  384. X                print "\r\n";
  385. X                redo loop;
  386. X            }
  387. X                                            # (DEL) || (BS) erase
  388. X        elsif ($c eq $erase1 || $c eq $erase2) {
  389. X        if($r) {
  390. X            print "\b \b";
  391. X            chop ($return);
  392. X            $r--;
  393. X        }
  394. X        }
  395. X        elsif ($c =~ /\S/) {                # printable char
  396. X        $return .= $c;
  397. X        $r++;
  398. X        print $c;
  399. X        }
  400. X    }
  401. X    }
  402. X    system 'stty -raw echo';
  403. X    print "\n";
  404. X    $return;
  405. X}
  406. X
  407. X1;
  408. !STUFFY!FUNK!
  409. echo Extracting eg/scan/scanner
  410. sed >eg/scan/scanner <<'!STUFFY!FUNK!' -e 's/X//'
  411. X#!/usr/bin/perl
  412. X
  413. X# $Header: scanner,v 4.0 91/03/20 01:14:11 lwall Locked $
  414. X
  415. X# This runs all the scan_* routines on all the machines in /etc/ghosts.
  416. X# We run this every morning at about 6 am:
  417. X
  418. X#    !/bin/sh
  419. X#    cd /usr/adm/private
  420. X#    decrypt scanner | perl >scan.out 2>&1
  421. X#    mail admin <scan.out
  422. X
  423. X# Note that the scan_* files should be encrypted with the key "-inquire", and
  424. X# scanner should be encrypted somehow so that people can't find that key.
  425. X# I leave it up to you to figure out how to unencrypt it before executing.
  426. X
  427. X$ENV{'PATH'} = '/bin:/usr/bin:/usr/local/bin:/usr/ucb:.';
  428. X
  429. X$| = 1;        # command buffering on stdout
  430. X
  431. Xprint "Subject: bizarre happenings\n\n";
  432. X
  433. X(chdir '/usr/adm/private') || die "Can't cd to /usr/adm/private: $!\n";
  434. X
  435. Xif ($#ARGV >= 0) {
  436. X    @scanlist = @ARGV;
  437. X} else {
  438. X    @scanlist = split(/[ \t\n]+/,`echo scan_*`);
  439. X}
  440. X
  441. Xscan: while ($scan = shift(@scanlist)) {
  442. X    print "\n********** $scan **********\n";
  443. X    $showhost++;
  444. X
  445. X    $systype = 'all';
  446. X
  447. X    open(ghosts, '/etc/ghosts') || die 'No /etc/ghosts file';
  448. X
  449. X    $one_of_these = ":$systype:";
  450. X    if ($systype =~ s/\+/[+]/g) {
  451. X    $one_of_these =~ s/\+/:/g;
  452. X    }
  453. X
  454. X    line: while (<ghosts>) {
  455. X    s/[ \t]*\n//;
  456. X    if (!$_ || /^#/) {
  457. X        next line;
  458. X    }
  459. X    if (/^([a-zA-Z_0-9]+)=(.+)/) {
  460. X        $name = $1; $repl = $2;
  461. X        $repl =~ s/\+/:/g;
  462. X        $one_of_these =~ s/:$name:/:$repl:/;
  463. X        next line;
  464. X    }
  465. X    @gh = split;
  466. X    $host = $gh[0];
  467. X    if ($showhost) { $showhost = "$host:\t"; }
  468. X    class: while ($class = pop(gh)) {
  469. X        if (index($one_of_these,":$class:") >=0) {
  470. X        $iter = 0;
  471. X        `exec crypt -inquire <$scan >.x 2>/dev/null`;
  472. X        unless (open(scan,'.x')) {
  473. X            print "Can't run $scan: $!\n";
  474. X            next scan;
  475. X        }
  476. X        $cmd = <scan>;
  477. X        unless ($cmd =~ s/#!(.*)\n/$1/) {
  478. X            $cmd = '/usr/bin/perl';
  479. X        }
  480. X        close(scan);
  481. X        if (open(PIPE,"exec rsh $host '$cmd' <.x|")) {
  482. X            sleep(5);
  483. X            unlink '.x';
  484. X            while (<PIPE>) {
  485. X            last if $iter++ > 1000;        # must be looping
  486. X            next if /^[0-9.]+u [0-9.]+s/;
  487. X            print $showhost,$_;
  488. X            }
  489. X            close(PIPE);
  490. X        } else {
  491. X            print "(Can't execute rsh: $!)\n";
  492. X        }
  493. X        last class;
  494. X        }
  495. X    }
  496. X    }
  497. X}
  498. !STUFFY!FUNK!
  499. echo Extracting eg/g/gcp.man
  500. sed >eg/g/gcp.man <<'!STUFFY!FUNK!' -e 's/X//'
  501. X.\" $Header: gcp.man,v 4.0 91/03/20 01:10:13 lwall Locked $
  502. X.TH GCP 1C "13 May 1988"
  503. X.SH NAME
  504. Xgcp \- global file copy
  505. X.SH SYNOPSIS
  506. X.B gcp
  507. Xfile1 file2
  508. X.br
  509. X.B gcp
  510. X[
  511. X.B \-r
  512. X] file ... directory
  513. X.SH DESCRIPTION
  514. X.I gcp
  515. Xworks just like rcp(1C) except that you may specify a set of hosts to copy files
  516. Xfrom or to.
  517. XThe host sets are defined in the file /etc/ghosts.
  518. X(An individual host name can be used as a set containing one member.)
  519. XYou can give a command like
  520. X
  521. X    gcp /etc/motd sun:
  522. X
  523. Xto copy your /etc/motd file to /etc/motd on all the Suns.
  524. XIf, on the other hand, you say
  525. X
  526. X    gcp /a/foo /b/bar sun:/tmp
  527. X
  528. Xthen your files will be copied to /tmp on all the Suns.
  529. XThe general rule is that if you don't specify the destination directory,
  530. Xfiles go to the same directory they are in currently.
  531. X.P
  532. XYou may specify the union of two or more sets by using + as follows:
  533. X
  534. X    gcp /a/foo /b/bar 750+mc:
  535. X
  536. Xwhich will copy /a/foo to /a/foo on all 750's and Masscomps, and then copy
  537. X/b/bar to /b/bar on all 750's and Masscomps.
  538. X.P
  539. XCommonly used sets should be defined in /etc/ghosts.
  540. XFor example, you could add a line that says
  541. X
  542. X    pep=manny+moe+jack
  543. X
  544. XAnother way to do that would be to add the word "pep" after each of the host
  545. Xentries:
  546. X
  547. X    manny    sun3 pep
  548. X.br
  549. X    moe        sun3 pep
  550. X.br
  551. X    jack        sun3 pep
  552. X
  553. XHosts and sets of host can also be excluded:
  554. X
  555. X    foo=sun-sun2
  556. X
  557. XAny host so excluded will never be included, even if a subsequent set on the
  558. Xline includes it:
  559. X
  560. X    foo=abc+def
  561. X.br
  562. X    bar=xyz-abc+foo
  563. X
  564. Xcomes out to xyz+def.
  565. X
  566. XYou can define private host sets by creating .ghosts in your current directory
  567. Xwith entries just like /etc/ghosts.
  568. XAlso, if there is a file .grem, it defines "rem" to be the remaining hosts
  569. Xfrom the last gsh or gcp that didn't succeed everywhere.
  570. X.PP
  571. XInterrupting with a SIGINT will cause the rcp to the current host to be skipped
  572. Xand execution resumed with the next host.
  573. XTo stop completely, send a SIGQUIT.
  574. X.SH SEE ALSO
  575. Xrcp(1C)
  576. X.SH BUGS
  577. XAll the bugs of rcp, since it calls rcp.
  578. !STUFFY!FUNK!
  579. echo Extracting t/TEST
  580. sed >t/TEST <<'!STUFFY!FUNK!' -e 's/X//'
  581. X#!./perl
  582. X
  583. X# $Header: TEST,v 4.0 91/03/20 01:40:22 lwall Locked $
  584. X
  585. X# This is written in a peculiar style, since we're trying to avoid
  586. X# most of the constructs we'll be testing for.
  587. X
  588. X$| = 1;
  589. X
  590. Xif ($ARGV[0] eq '-v') {
  591. X    $verbose = 1;
  592. X    shift;
  593. X}
  594. X
  595. Xchdir 't' if -f 't/TEST';
  596. X
  597. Xif ($ARGV[0] eq '') {
  598. X    @ARGV = split(/[ \n]/,
  599. X      `echo base/*.t comp/*.t cmd/*.t io/*.t; echo op/*.t lib/*.t`);
  600. X}
  601. X
  602. Xopen(CONFIG,"../config.sh");
  603. Xwhile (<CONFIG>) {
  604. X    if (/sharpbang='(.*)'/) {
  605. X    $sharpbang = ($1 eq '#!');
  606. X    last;
  607. X    }
  608. X}
  609. X$bad = 0;
  610. Xwhile ($test = shift) {
  611. X    if ($test =~ /^$/) {
  612. X    next;
  613. X    }
  614. X    $te = $test;
  615. X    chop($te);
  616. X    print "$te" . '.' x (15 - length($te));
  617. X    if ($sharpbang) {
  618. X    open(results,"./$test|") || (print "can't run.\n");
  619. X    } else {
  620. X    open(script,"$test") || die "Can't run $test.\n";
  621. X    $_ = <script>;
  622. X    close(script);
  623. X    if (/#!..perl(.*)/) {
  624. X        $switch = $1;
  625. X    } else {
  626. X        $switch = '';
  627. X    }
  628. X    open(results,"./perl$switch $test|") || (print "can't run.\n");
  629. X    }
  630. X    $ok = 0;
  631. X    $next = 0;
  632. X    while (<results>) {
  633. X    if ($verbose) {
  634. X        print $_;
  635. X    }
  636. X    unless (/^#/) {
  637. X        if (/^1\.\.([0-9]+)/) {
  638. X        $max = $1;
  639. X        $next = 1;
  640. X        $ok = 1;
  641. X        } else {
  642. X        $next = $1, $ok = 0, last if /^not ok ([0-9]*)/;
  643. X        if (/^ok (.*)/ && $1 == $next) {
  644. X            $next = $next + 1;
  645. X        } else {
  646. X            $ok = 0;
  647. X        }
  648. X        }
  649. X    }
  650. X    }
  651. X    $next = $next - 1;
  652. X    if ($ok && $next == $max) {
  653. X    print "ok\n";
  654. X    } else {
  655. X    $next += 1;
  656. X    print "FAILED on test $next\n";
  657. X    $bad = $bad + 1;
  658. X    $_ = $test;
  659. X    if (/^base/) {
  660. X        die "Failed a basic test--cannot continue.\n";
  661. X    }
  662. X    }
  663. X}
  664. X
  665. Xif ($bad == 0) {
  666. X    if ($ok) {
  667. X    print "All tests successful.\n";
  668. X    } else {
  669. X    die "FAILED--no tests were run for some reason.\n";
  670. X    }
  671. X} else {
  672. X    if ($bad == 1) {
  673. X    die "Failed 1 test.\n";
  674. X    } else {
  675. X    die "Failed $bad tests.\n";
  676. X    }
  677. X}
  678. X($user,$sys,$cuser,$csys) = times;
  679. Xprint sprintf("u=%g  s=%g  cu=%g  cs=%g\n",$user,$sys,$cuser,$csys);
  680. !STUFFY!FUNK!
  681. echo Extracting eg/rename
  682. sed >eg/rename <<'!STUFFY!FUNK!' -e 's/X//'
  683. X#!/usr/bin/perl
  684. X'di';
  685. X'ig00';
  686. X#
  687. X# $Header: rename,v 4.0 91/03/20 01:11:53 lwall Locked $
  688. X#
  689. X# $Log:    rename,v $
  690. X# Revision 4.0  91/03/20  01:11:53  lwall
  691. X# 4.0 baseline.
  692. X# 
  693. X# Revision 3.0.1.2  90/08/09  03:17:57  lwall
  694. X# patch19: added man page for relink and rename
  695. X# 
  696. X
  697. X($op = shift) || die "Usage: rename perlexpr [filenames]\n";
  698. Xif (!@ARGV) {
  699. X    @ARGV = <STDIN>;
  700. X    chop(@ARGV);
  701. X}
  702. Xfor (@ARGV) {
  703. X    $was = $_;
  704. X    eval $op;
  705. X    die $@ if $@;
  706. X    rename($was,$_) unless $was eq $_;
  707. X}
  708. X##############################################################################
  709. X
  710. X    # These next few lines are legal in both Perl and nroff.
  711. X
  712. X.00;            # finish .ig
  713. X 
  714. X'di            \" finish diversion--previous line must be blank
  715. X.nr nl 0-1        \" fake up transition to first page again
  716. X.nr % 0            \" start at page 1
  717. X';<<'.ex'; #__END__ ############# From here on it's a standard manual page ############
  718. X.TH RENAME 1 "July 30, 1990"
  719. X.AT 3
  720. X.SH NAME
  721. Xrename \- renames multiple files
  722. X.SH SYNOPSIS
  723. X.B rename perlexpr [files]
  724. X.SH DESCRIPTION
  725. X.I Rename
  726. Xrenames the filenames supplied according to the rule specified as the
  727. Xfirst argument.
  728. XThe argument is a Perl expression which is expected to modify the $_
  729. Xstring in Perl for at least some of the filenames specified.
  730. XIf a given filename is not modified by the expression, it will not be
  731. Xrenamed.
  732. XIf no filenames are given on the command line, filenames will be read
  733. Xvia standard input.
  734. X.PP
  735. XFor example, to rename all files matching *.bak to strip the extension,
  736. Xyou might say
  737. X.nf
  738. X
  739. X    rename 's/\e.bak$//' *.bak
  740. X
  741. X.fi
  742. XTo translate uppercase names to lower, you'd use
  743. X.nf
  744. X
  745. X    rename 'y/A-Z/a-z/' *
  746. X
  747. X.fi
  748. X.SH ENVIRONMENT
  749. XNo environment variables are used.
  750. X.SH FILES
  751. X.SH AUTHOR
  752. XLarry Wall
  753. X.SH "SEE ALSO"
  754. Xmv(1)
  755. X.br
  756. Xperl(1)
  757. X.SH DIAGNOSTICS
  758. XIf you give an invalid Perl expression you'll get a syntax error.
  759. X.SH BUGS
  760. X.I Rename
  761. Xdoes not check for the existence of target filenames, so use with care.
  762. X.ex
  763. !STUFFY!FUNK!
  764. echo Extracting msdos/usage.c
  765. sed >msdos/usage.c <<'!STUFFY!FUNK!' -e 's/X//'
  766. X/*    usage.c
  767. X *
  768. X * Show usage message.
  769. X */
  770. X
  771. X#include <stdio.h>
  772. X#include <string.h>
  773. X
  774. X
  775. Xusage(char *myname)
  776. X{
  777. Xchar    * p;
  778. Xchar     * name_p;
  779. X
  780. Xname_p = myname;
  781. Xif ( p = strrchr(myname,'/') )
  782. X    name_p = p+1;    /* point after final '/' */
  783. X#ifdef MSDOS
  784. Xif ( p = strrchr(name_p,'\\') )
  785. X    name_p = p+1;    /* point after final '\\' */
  786. Xif ( p = strrchr(name_p,':') )
  787. X    name_p = p+1;    /* point after final ':' */
  788. X  printf("\nUsage: %s [-acdnpsSvw] [-Dnumber] [-i[extension]] [-Idirectory]"
  789. X#else
  790. X  printf("\nUsage: %s [-acdnpPsSuUvw] [-Dnumber] [-i[extension]] [-Idirectory]"
  791. X#endif
  792. X         "\n            [-e \"command\"] [-x[directory]] [filename] [arguments]\n", name_p);
  793. X
  794. X  printf("\n  -a  autosplit mode with -n or -p"
  795. X         "\n  -c  syntaxcheck only"
  796. X         "\n  -d  run scripts under debugger"
  797. X         "\n  -n  assume 'while (<>) { ...script... }' loop arround your script"
  798. X         "\n  -p  assume loop like -n but print line also like sed"
  799. X#ifndef MSDOS
  800. X         "\n  -P  run script through C preprocessor befor compilation"
  801. X#endif
  802. X         "\n  -s  enable some switch parsing for switches after script name"
  803. X         "\n  -S  look for the script using PATH environment variable");
  804. X#ifndef MSDOS
  805. X  printf("\n  -u  dump core after compiling the script"
  806. X         "\n  -U  allow unsafe operations");
  807. X#endif
  808. X  printf("\n  -v  print version number and patchlevel of perl"
  809. X         "\n  -w  turn warnings on for compilation of your script\n"
  810. X         "\n  -Dnumber        set debugging flags"
  811. X         "\n  -i[extension]   edit <> files in place (make backup if extension supplied)"
  812. X         "\n  -Idirectory     specify include directory in conjunction with -P"
  813. X         "\n  -e command      one line of script, multiple -e options are allowed"
  814. X         "\n                  [filename] can be ommitted, when -e is used"
  815. X         "\n  -x[directory]   strip off text before #!perl line and perhaps cd to directory\n");
  816. X}
  817. !STUFFY!FUNK!
  818. echo Extracting t/op/split.t
  819. sed >t/op/split.t <<'!STUFFY!FUNK!' -e 's/X//'
  820. X#!./perl
  821. X
  822. X# $Header: split.t,v 4.0 91/03/20 01:54:42 lwall Locked $
  823. X
  824. Xprint "1..12\n";
  825. X
  826. X$FS = ':';
  827. X
  828. X$_ = 'a:b:c';
  829. X
  830. X($a,$b,$c) = split($FS,$_);
  831. X
  832. Xif (join(';',$a,$b,$c) eq 'a;b;c') {print "ok 1\n";} else {print "not ok 1\n";}
  833. X
  834. X@ary = split(/:b:/);
  835. Xif (join("$_",@ary) eq 'aa:b:cc') {print "ok 2\n";} else {print "not ok 2\n";}
  836. X
  837. X$_ = "abc\n";
  838. X@xyz = (@ary = split(//));
  839. Xif (join(".",@ary) eq "a.b.c.\n") {print "ok 3\n";} else {print "not ok 3\n";}
  840. X
  841. X$_ = "a:b:c::::";
  842. X@ary = split(/:/);
  843. Xif (join(".",@ary) eq "a.b.c") {print "ok 4\n";} else {print "not ok 4\n";}
  844. X
  845. X$_ = join(':',split(' ',"    a b\tc \t d "));
  846. Xif ($_ eq 'a:b:c:d') {print "ok 5\n";} else {print "not ok 5 #$_#\n";}
  847. X
  848. X$_ = join(':',split(/ */,"foo  bar bie\tdoll"));
  849. Xif ($_ eq "f:o:o:b:a:r:b:i:e:\t:d:o:l:l")
  850. X    {print "ok 6\n";} else {print "not ok 6\n";}
  851. X
  852. X$_ = join(':', 'foo', split(/ /,'a b  c'), 'bar');
  853. Xif ($_ eq "foo:a:b::c:bar") {print "ok 7\n";} else {print "not ok 7 $_\n";}
  854. X
  855. X# Can we say how many fields to split to?
  856. X$_ = join(':', split(' ','1 2 3 4 5 6', 3));
  857. Xprint $_ eq '1:2:3 4 5 6' ? "ok 8\n" : "not ok 8 $_\n";
  858. X
  859. X# Can we do it as a variable?
  860. X$x = 4;
  861. X$_ = join(':', split(' ','1 2 3 4 5 6', $x));
  862. Xprint $_ eq '1:2:3:4 5 6' ? "ok 9\n" : "not ok 9 $_\n";
  863. X
  864. X# Does the 999 suppress null field chopping?
  865. X$_ = join(':', split(/:/,'1:2:3:4:5:6:::', 999));
  866. Xprint $_ eq '1:2:3:4:5:6:::' ? "ok 10\n" : "not ok 10 $_\n";
  867. X
  868. X# Does assignment to a list imply split to one more field than that?
  869. X$foo = `./perl -D1024 -e '(\$a,\$b) = split;' 2>&1`;
  870. Xprint $foo =~ /DEBUGGING/ || $foo =~ /num\(3\)/ ? "ok 11\n" : "not ok 11\n";
  871. X
  872. X# Can we say how many fields to split to when assigning to a list?
  873. X($a,$b) = split(' ','1 2 3 4 5 6', 2);
  874. X$_ = join(':',$a,$b);
  875. Xprint $_ eq '1:2 3 4 5 6' ? "ok 12\n" : "not ok 12 $_\n";
  876. X
  877. !STUFFY!FUNK!
  878. echo Extracting h2pl/eg/sys/errno.pl
  879. sed >h2pl/eg/sys/errno.pl <<'!STUFFY!FUNK!' -e 's/X//'
  880. X$EPERM = 0x1;
  881. X$ENOENT = 0x2;
  882. X$ESRCH = 0x3;
  883. X$EINTR = 0x4;
  884. X$EIO = 0x5;
  885. X$ENXIO = 0x6;
  886. X$E2BIG = 0x7;
  887. X$ENOEXEC = 0x8;
  888. X$EBADF = 0x9;
  889. X$ECHILD = 0xA;
  890. X$EAGAIN = 0xB;
  891. X$ENOMEM = 0xC;
  892. X$EACCES = 0xD;
  893. X$EFAULT = 0xE;
  894. X$ENOTBLK = 0xF;
  895. X$EBUSY = 0x10;
  896. X$EEXIST = 0x11;
  897. X$EXDEV = 0x12;
  898. X$ENODEV = 0x13;
  899. X$ENOTDIR = 0x14;
  900. X$EISDIR = 0x15;
  901. X$EINVAL = 0x16;
  902. X$ENFILE = 0x17;
  903. X$EMFILE = 0x18;
  904. X$ENOTTY = 0x19;
  905. X$ETXTBSY = 0x1A;
  906. X$EFBIG = 0x1B;
  907. X$ENOSPC = 0x1C;
  908. X$ESPIPE = 0x1D;
  909. X$EROFS = 0x1E;
  910. X$EMLINK = 0x1F;
  911. X$EPIPE = 0x20;
  912. X$EDOM = 0x21;
  913. X$ERANGE = 0x22;
  914. X$EWOULDBLOCK = 0x23;
  915. X$EINPROGRESS = 0x24;
  916. X$EALREADY = 0x25;
  917. X$ENOTSOCK = 0x26;
  918. X$EDESTADDRREQ = 0x27;
  919. X$EMSGSIZE = 0x28;
  920. X$EPROTOTYPE = 0x29;
  921. X$ENOPROTOOPT = 0x2A;
  922. X$EPROTONOSUPPORT = 0x2B;
  923. X$ESOCKTNOSUPPORT = 0x2C;
  924. X$EOPNOTSUPP = 0x2D;
  925. X$EPFNOSUPPORT = 0x2E;
  926. X$EAFNOSUPPORT = 0x2F;
  927. X$EADDRINUSE = 0x30;
  928. X$EADDRNOTAVAIL = 0x31;
  929. X$ENETDOWN = 0x32;
  930. X$ENETUNREACH = 0x33;
  931. X$ENETRESET = 0x34;
  932. X$ECONNABORTED = 0x35;
  933. X$ECONNRESET = 0x36;
  934. X$ENOBUFS = 0x37;
  935. X$EISCONN = 0x38;
  936. X$ENOTCONN = 0x39;
  937. X$ESHUTDOWN = 0x3A;
  938. X$ETOOMANYREFS = 0x3B;
  939. X$ETIMEDOUT = 0x3C;
  940. X$ECONNREFUSED = 0x3D;
  941. X$ELOOP = 0x3E;
  942. X$ENAMETOOLONG = 0x3F;
  943. X$EHOSTDOWN = 0x40;
  944. X$EHOSTUNREACH = 0x41;
  945. X$ENOTEMPTY = 0x42;
  946. X$EPROCLIM = 0x43;
  947. X$EUSERS = 0x44;
  948. X$EDQUOT = 0x45;
  949. X$ESTALE = 0x46;
  950. X$EREMOTE = 0x47;
  951. X$EDEADLK = 0x48;
  952. X$ENOLCK = 0x49;
  953. X$MTH_UNDEF_SQRT = 0x12C;
  954. X$MTH_OVF_EXP = 0x12D;
  955. X$MTH_UNDEF_LOG = 0x12E;
  956. X$MTH_NEG_BASE = 0x12F;
  957. X$MTH_ZERO_BASE = 0x130;
  958. X$MTH_OVF_POW = 0x131;
  959. X$MTH_LRG_SIN = 0x132;
  960. X$MTH_LRG_COS = 0x133;
  961. X$MTH_LRG_TAN = 0x134;
  962. X$MTH_LRG_COT = 0x135;
  963. X$MTH_OVF_TAN = 0x136;
  964. X$MTH_OVF_COT = 0x137;
  965. X$MTH_UNDEF_ASIN = 0x138;
  966. X$MTH_UNDEF_ACOS = 0x139;
  967. X$MTH_UNDEF_ATAN2 = 0x13A;
  968. X$MTH_OVF_SINH = 0x13B;
  969. X$MTH_OVF_COSH = 0x13C;
  970. X$MTH_UNDEF_ZLOG = 0x13D;
  971. X$MTH_UNDEF_ZDIV = 0x13E;
  972. !STUFFY!FUNK!
  973. echo Extracting t/op/substr.t
  974. sed >t/op/substr.t <<'!STUFFY!FUNK!' -e 's/X//'
  975. X#!./perl
  976. X
  977. X# $Header: substr.t,v 4.0 91/03/20 01:55:05 lwall Locked $
  978. X
  979. Xprint "1..22\n";
  980. X
  981. X$a = 'abcdefxyz';
  982. X
  983. Xprint (substr($a,0,3) eq 'abc' ? "ok 1\n" : "not ok 1\n");
  984. Xprint (substr($a,3,3) eq 'def' ? "ok 2\n" : "not ok 2\n");
  985. Xprint (substr($a,6,999) eq 'xyz' ? "ok 3\n" : "not ok 3\n");
  986. Xprint (substr($a,999,999) eq '' ? "ok 4\n" : "not ok 4\n");
  987. Xprint (substr($a,6,-1) eq '' ? "ok 5\n" : "not ok 5\n");
  988. Xprint (substr($a,-3,1) eq 'x' ? "ok 6\n" : "not ok 6\n");
  989. X
  990. X$[ = 1;
  991. X
  992. Xprint (substr($a,1,3) eq 'abc' ? "ok 7\n" : "not ok 7\n");
  993. Xprint (substr($a,4,3) eq 'def' ? "ok 8\n" : "not ok 8\n");
  994. Xprint (substr($a,7,999) eq 'xyz' ? "ok 9\n" : "not ok 9\n");
  995. Xprint (substr($a,999,999) eq '' ? "ok 10\n" : "not ok 10\n");
  996. Xprint (substr($a,7,-1) eq '' ? "ok 11\n" : "not ok 11\n");
  997. Xprint (substr($a,-3,1) eq 'x' ? "ok 12\n" : "not ok 12\n");
  998. X
  999. X$[ = 0;
  1000. X
  1001. Xsubstr($a,3,3) = 'XYZ';
  1002. Xprint $a eq 'abcXYZxyz' ? "ok 13\n" : "not ok 13\n";
  1003. Xsubstr($a,0,2) = '';
  1004. Xprint $a eq 'cXYZxyz' ? "ok 14\n" : "not ok 14\n";
  1005. Xy/a/a/;
  1006. Xsubstr($a,0,0) = 'ab';
  1007. Xprint $a eq 'abcXYZxyz' ? "ok 15\n" : "not ok 15 $a\n";
  1008. Xsubstr($a,0,0) = '12345678';
  1009. Xprint $a eq '12345678abcXYZxyz' ? "ok 16\n" : "not ok 16\n";
  1010. Xsubstr($a,-3,3) = 'def';
  1011. Xprint $a eq '12345678abcXYZdef' ? "ok 17\n" : "not ok 17\n";
  1012. Xsubstr($a,-3,3) = '<';
  1013. Xprint $a eq '12345678abcXYZ<' ? "ok 18\n" : "not ok 18\n";
  1014. Xsubstr($a,-1,1) = '12345678';
  1015. Xprint $a eq '12345678abcXYZ12345678' ? "ok 19\n" : "not ok 19\n";
  1016. X
  1017. X$a = 'abcdefxyz';
  1018. X
  1019. Xprint (substr($a,6) eq 'xyz' ? "ok 20\n" : "not ok 20\n");
  1020. Xprint (substr($a,-3) eq 'xyz' ? "ok 21\n" : "not ok 21\n");
  1021. Xprint (substr($a,999) eq '' ? "ok 22\n" : "not ok 22\n");
  1022. !STUFFY!FUNK!
  1023. echo Extracting t/op/index.t
  1024. sed >t/op/index.t <<'!STUFFY!FUNK!' -e 's/X//'
  1025. X#!./perl
  1026. X
  1027. X# $Header: index.t,v 4.0 91/03/20 01:53:05 lwall Locked $
  1028. X
  1029. Xprint "1..20\n";
  1030. X
  1031. X
  1032. X$foo = 'Now is the time for all good men to come to the aid of their country.';
  1033. X
  1034. X$first = substr($foo,0,index($foo,'the'));
  1035. Xprint ($first eq "Now is " ? "ok 1\n" : "not ok 1\n");
  1036. X
  1037. X$last = substr($foo,rindex($foo,'the'),100);
  1038. Xprint ($last eq "their country." ? "ok 2\n" : "not ok 2\n");
  1039. X
  1040. X$last = substr($foo,index($foo,'Now'),2);
  1041. Xprint ($last eq "No" ? "ok 3\n" : "not ok 3\n");
  1042. X
  1043. X$last = substr($foo,rindex($foo,'Now'),2);
  1044. Xprint ($last eq "No" ? "ok 4\n" : "not ok 4\n");
  1045. X
  1046. X$last = substr($foo,index($foo,'.'),100);
  1047. Xprint ($last eq "." ? "ok 5\n" : "not ok 5\n");
  1048. X
  1049. X$last = substr($foo,rindex($foo,'.'),100);
  1050. Xprint ($last eq "." ? "ok 6\n" : "not ok 6\n");
  1051. X
  1052. Xprint index("ababa","a",-1) == 0 ? "ok 7\n" : "not ok 7\n";
  1053. Xprint index("ababa","a",0) == 0 ? "ok 8\n" : "not ok 8\n";
  1054. Xprint index("ababa","a",1) == 2 ? "ok 9\n" : "not ok 9\n";
  1055. Xprint index("ababa","a",2) == 2 ? "ok 10\n" : "not ok 10\n";
  1056. Xprint index("ababa","a",3) == 4 ? "ok 11\n" : "not ok 11\n";
  1057. Xprint index("ababa","a",4) == 4 ? "ok 12\n" : "not ok 12\n";
  1058. Xprint index("ababa","a",5) == -1 ? "ok 13\n" : "not ok 13\n";
  1059. X
  1060. Xprint rindex("ababa","a",-1) == -1 ? "ok 14\n" : "not ok 14\n";
  1061. Xprint rindex("ababa","a",0) == 0 ? "ok 15\n" : "not ok 15\n";
  1062. Xprint rindex("ababa","a",1) == 0 ? "ok 16\n" : "not ok 16\n";
  1063. Xprint rindex("ababa","a",2) == 2 ? "ok 17\n" : "not ok 17\n";
  1064. Xprint rindex("ababa","a",3) == 2 ? "ok 18\n" : "not ok 18\n";
  1065. Xprint rindex("ababa","a",4) == 4 ? "ok 19\n" : "not ok 19\n";
  1066. Xprint rindex("ababa","a",5) == 4 ? "ok 20\n" : "not ok 20\n";
  1067. !STUFFY!FUNK!
  1068. echo Extracting hash.h
  1069. sed >hash.h <<'!STUFFY!FUNK!' -e 's/X//'
  1070. X/* $Header: hash.h,v 4.0 91/03/20 01:22:38 lwall Locked $
  1071. X *
  1072. X *    Copyright (c) 1989, Larry Wall
  1073. X *
  1074. X *    You may distribute under the terms of the GNU General Public License
  1075. X *    as specified in the README file that comes with the perl 3.0 kit.
  1076. X *
  1077. X * $Log:    hash.h,v $
  1078. X * Revision 4.0  91/03/20  01:22:38  lwall
  1079. X * 4.0 baseline.
  1080. X * 
  1081. X */
  1082. X
  1083. X#define FILLPCT 80        /* don't make greater than 99 */
  1084. X#define DBM_CACHE_MAX 63    /* cache 64 entries for dbm file */
  1085. X                /* (resident array acts as a write-thru cache)*/
  1086. X
  1087. X#define COEFFSIZE (16 * 8)    /* size of coeff array */
  1088. X
  1089. Xtypedef struct hentry HENT;
  1090. X
  1091. Xstruct hentry {
  1092. X    HENT    *hent_next;
  1093. X    char    *hent_key;
  1094. X    STR        *hent_val;
  1095. X    int        hent_hash;
  1096. X    int        hent_klen;
  1097. X};
  1098. X
  1099. Xstruct htbl {
  1100. X    HENT    **tbl_array;
  1101. X    int        tbl_max;    /* subscript of last element of tbl_array */
  1102. X    int        tbl_dosplit;    /* how full to get before splitting */
  1103. X    int        tbl_fill;    /* how full tbl_array currently is */
  1104. X    int        tbl_riter;    /* current root of iterator */
  1105. X    HENT    *tbl_eiter;    /* current entry of iterator */
  1106. X    SPAT     *tbl_spatroot;    /* list of spats for this package */
  1107. X    char    *tbl_name;    /* name, if a symbol table */
  1108. X#ifdef SOME_DBM
  1109. X#ifdef HAS_GDBM
  1110. X    GDBM_FILE    tbl_dbm;
  1111. X#else
  1112. X#ifdef HAS_NDBM
  1113. X    DBM        *tbl_dbm;
  1114. X#else
  1115. X    int        tbl_dbm;
  1116. X#endif
  1117. X#endif
  1118. X#endif
  1119. X    unsigned char tbl_coeffsize;    /* is 0 for symbol tables */
  1120. X};
  1121. X
  1122. XSTR *hfetch();
  1123. Xbool hstore();
  1124. XSTR *hdelete();
  1125. XHASH *hnew();
  1126. Xvoid hclear();
  1127. Xvoid hentfree();
  1128. Xint hiterinit();
  1129. XHENT *hiternext();
  1130. Xchar *hiterkey();
  1131. XSTR *hiterval();
  1132. Xbool hdbmopen();
  1133. Xvoid hdbmclose();
  1134. Xbool hdbmstore();
  1135. !STUFFY!FUNK!
  1136. echo Extracting t/op/repeat.t
  1137. sed >t/op/repeat.t <<'!STUFFY!FUNK!' -e 's/X//'
  1138. X#!./perl
  1139. X
  1140. X# $Header: repeat.t,v 4.0 91/03/20 01:54:26 lwall Locked $
  1141. X
  1142. Xprint "1..19\n";
  1143. X
  1144. X# compile time
  1145. X
  1146. Xif ('-' x 5 eq '-----') {print "ok 1\n";} else {print "not ok 1\n";}
  1147. Xif ('-' x 1 eq '-') {print "ok 2\n";} else {print "not ok 2\n";}
  1148. Xif ('-' x 0 eq '') {print "ok 3\n";} else {print "not ok 3\n";}
  1149. X
  1150. Xif ('ab' x 3 eq 'ababab') {print "ok 4\n";} else {print "not ok 4\n";}
  1151. X
  1152. X# run time
  1153. X
  1154. X$a = '-';
  1155. Xif ($a x 5 eq '-----') {print "ok 5\n";} else {print "not ok 5\n";}
  1156. Xif ($a x 1 eq '-') {print "ok 6\n";} else {print "not ok 6\n";}
  1157. Xif ($a x 0 eq '') {print "ok 7\n";} else {print "not ok 7\n";}
  1158. X
  1159. X$a = 'ab';
  1160. Xif ($a x 3 eq 'ababab') {print "ok 8\n";} else {print "not ok 8\n";}
  1161. X
  1162. X$a = 'xyz';
  1163. X$a x= 2;
  1164. Xif ($a eq 'xyzxyz') {print "ok 9\n";} else {print "not ok 9\n";}
  1165. X$a x= 1;
  1166. Xif ($a eq 'xyzxyz') {print "ok 10\n";} else {print "not ok 10\n";}
  1167. X$a x= 0;
  1168. Xif ($a eq '') {print "ok 11\n";} else {print "not ok 11\n";}
  1169. X
  1170. X@x = (1,2,3);
  1171. X
  1172. Xprint join('', @x x 4) eq '3333' ? "ok 12\n" : "not ok 12\n";
  1173. Xprint join('', (@x) x 4) eq '123123123123' ? "ok 13\n" : "not ok 13\n";
  1174. Xprint join('', (@x,()) x 4) eq '123123123123' ? "ok 14\n" : "not ok 14\n";
  1175. Xprint join('', (@x,1) x 4) eq '1231123112311231' ? "ok 15\n" : "not ok 15\n";
  1176. Xprint join(':', () x 4) eq '' ? "ok 16\n" : "not ok 16\n";
  1177. Xprint join(':', (9) x 4) eq '9:9:9:9' ? "ok 17\n" : "not ok 17\n";
  1178. Xprint join(':', (9,9) x 4) eq '9:9:9:9:9:9:9:9' ? "ok 18\n" : "not ok 18\n";
  1179. Xprint join('', (split(//,"123")) x 2) eq '123123' ? "ok 19\n" : "not ok 19\n";
  1180. !STUFFY!FUNK!
  1181. echo Extracting msdos/dir.h
  1182. sed >msdos/dir.h <<'!STUFFY!FUNK!' -e 's/X//'
  1183. X/* $Header: dir.h,v 4.0 91/03/20 01:34:20 lwall Locked $
  1184. X *
  1185. X *    (C) Copyright 1987, 1990 Diomidis Spinellis.
  1186. X *
  1187. X *    You may distribute under the terms of the GNU General Public License
  1188. X *    as specified in the README file that comes with the perl 3.0 kit.
  1189. X *
  1190. X * $Log:    dir.h,v $
  1191. X * Revision 4.0  91/03/20  01:34:20  lwall
  1192. X * 4.0 baseline.
  1193. X * 
  1194. X * Revision 3.0.1.1  90/03/27  16:07:08  lwall
  1195. X * patch16: MSDOS support
  1196. X * 
  1197. X * Revision 1.1  90/03/18  20:32:29  dds
  1198. X * Initial revision
  1199. X *
  1200. X *
  1201. X */
  1202. X
  1203. X/*
  1204. X * defines the type returned by the directory(3) functions
  1205. X */
  1206. X
  1207. X#ifndef __DIR_INCLUDED
  1208. X#define __DIR_INCLUDED
  1209. X
  1210. X/*Directory entry size */
  1211. X#ifdef DIRSIZ
  1212. X#undef DIRSIZ
  1213. X#endif
  1214. X#define DIRSIZ(rp)    (sizeof(struct direct))
  1215. X
  1216. X/*
  1217. X * Structure of a directory entry
  1218. X */
  1219. Xstruct direct    {
  1220. X    ino_t    d_ino;            /* inode number (not used by MS-DOS) */
  1221. X    int    d_namlen;        /* Name length */
  1222. X    char    d_name[13];        /* file name */
  1223. X};
  1224. X
  1225. Xstruct _dir_struc {            /* Structure used by dir operations */
  1226. X    char *start;            /* Starting position */
  1227. X    char *curr;            /* Current position */
  1228. X    struct direct dirstr;        /* Directory structure to return */
  1229. X};
  1230. X
  1231. Xtypedef struct _dir_struc DIR;        /* Type returned by dir operations */
  1232. X
  1233. XDIR *cdecl opendir(char *filename);
  1234. Xstruct direct *readdir(DIR *dirp);
  1235. Xlong telldir(DIR *dirp);
  1236. Xvoid seekdir(DIR *dirp,long loc);
  1237. Xvoid rewinddir(DIR *dirp);
  1238. Xvoid closedir(DIR *dirp);
  1239. X
  1240. X#endif /* __DIR_INCLUDED */
  1241. !STUFFY!FUNK!
  1242. echo Extracting spat.h
  1243. sed >spat.h <<'!STUFFY!FUNK!' -e 's/X//'
  1244. X/* $Header: spat.h,v 4.0 91/03/20 01:39:36 lwall Locked $
  1245. X *
  1246. X *    Copyright (c) 1989, Larry Wall
  1247. X *
  1248. X *    You may distribute under the terms of the GNU General Public License
  1249. X *    as specified in the README file that comes with the perl 3.0 kit.
  1250. X *
  1251. X * $Log:    spat.h,v $
  1252. X * Revision 4.0  91/03/20  01:39:36  lwall
  1253. X * 4.0 baseline.
  1254. X * 
  1255. X */
  1256. X
  1257. Xstruct scanpat {
  1258. X    SPAT    *spat_next;        /* list of all scanpats */
  1259. X    REGEXP    *spat_regexp;        /* compiled expression */
  1260. X    ARG        *spat_repl;        /* replacement string for subst */
  1261. X    ARG        *spat_runtime;        /* compile pattern at runtime */
  1262. X    STR        *spat_short;        /* for a fast bypass of execute() */
  1263. X    bool    spat_flags;
  1264. X    char    spat_slen;
  1265. X};
  1266. X
  1267. X#define SPAT_USED 1            /* spat has been used once already */
  1268. X#define SPAT_ONCE 2            /* use pattern only once per reset */
  1269. X#define SPAT_SCANFIRST 4        /* initial constant not anchored */
  1270. X#define SPAT_ALL 8            /* initial constant is whole pat */
  1271. X#define SPAT_SKIPWHITE 16        /* skip leading whitespace for split */
  1272. X#define SPAT_FOLD 32            /* case insensitivity */
  1273. X#define SPAT_CONST 64            /* subst replacement is constant */
  1274. X#define SPAT_KEEP 128            /* keep 1st runtime pattern forever */
  1275. X
  1276. XEXT SPAT *curspat;        /* what to do \ interps from */
  1277. XEXT SPAT *lastspat;        /* what to use in place of null pattern */
  1278. X
  1279. XEXT char *hint INIT(Nullch);    /* hint from cmd_exec to do_match et al */
  1280. X
  1281. X#define Nullspat Null(SPAT*)
  1282. !STUFFY!FUNK!
  1283. echo Extracting t/op/undef.t
  1284. sed >t/op/undef.t <<'!STUFFY!FUNK!' -e 's/X//'
  1285. X#!./perl
  1286. X
  1287. X# $Header: undef.t,v 4.0 91/03/20 01:55:16 lwall Locked $
  1288. X
  1289. Xprint "1..21\n";
  1290. X
  1291. Xprint defined($a) ? "not ok 1\n" : "ok 1\n";
  1292. X
  1293. X$a = 1+1;
  1294. Xprint defined($a) ? "ok 2\n" : "not ok 2\n";
  1295. X
  1296. Xundef $a;
  1297. Xprint defined($a) ? "not ok 3\n" : "ok 3\n";
  1298. X
  1299. X$a = "hi";
  1300. Xprint defined($a) ? "ok 4\n" : "not ok 4\n";
  1301. X
  1302. X$a = $b;
  1303. Xprint defined($a) ? "not ok 5\n" : "ok 5\n";
  1304. X
  1305. X@ary = ("1arg");
  1306. X$a = pop(@ary);
  1307. Xprint defined($a) ? "ok 6\n" : "not ok 6\n";
  1308. X$a = pop(@ary);
  1309. Xprint defined($a) ? "not ok 7\n" : "ok 7\n";
  1310. X
  1311. X@ary = ("1arg");
  1312. X$a = shift(@ary);
  1313. Xprint defined($a) ? "ok 8\n" : "not ok 8\n";
  1314. X$a = shift(@ary);
  1315. Xprint defined($a) ? "not ok 9\n" : "ok 9\n";
  1316. X
  1317. X$ary{'foo'} = 'hi';
  1318. Xprint defined($ary{'foo'}) ? "ok 10\n" : "not ok 10\n";
  1319. Xprint defined($ary{'bar'}) ? "not ok 11\n" : "ok 11\n";
  1320. Xundef $ary{'foo'};
  1321. Xprint defined($ary{'foo'}) ? "not ok 12\n" : "ok 12\n";
  1322. X
  1323. Xprint defined(@ary) ? "ok 13\n" : "not ok 13\n";
  1324. Xprint defined(%ary) ? "ok 14\n" : "not ok 14\n";
  1325. Xundef @ary;
  1326. Xprint defined(@ary) ? "not ok 15\n" : "ok 15\n";
  1327. Xundef %ary;
  1328. Xprint defined(%ary) ? "not ok 16\n" : "ok 16\n";
  1329. X@ary = (1);
  1330. Xprint defined @ary ? "ok 17\n" : "not ok 17\n";
  1331. X%ary = (1,1);
  1332. Xprint defined %ary ? "ok 18\n" : "not ok 18\n";
  1333. X
  1334. Xsub foo { print "ok 19\n"; }
  1335. X
  1336. X&foo || print "not ok 19\n";
  1337. X
  1338. Xprint defined &foo ? "ok 20\n" : "not ok 20\n";
  1339. Xundef &foo;
  1340. Xprint defined(&foo) ? "not ok 21\n" : "ok 21\n";
  1341. !STUFFY!FUNK!
  1342. echo Extracting eg/van/unvanish
  1343. sed >eg/van/unvanish <<'!STUFFY!FUNK!' -e 's/X//'
  1344. X#!/usr/bin/perl
  1345. X
  1346. X# $Header: unvanish,v 4.0 91/03/20 01:15:38 lwall Locked $
  1347. X
  1348. Xsub it {
  1349. X    if ($olddir ne '.') {
  1350. X    chop($pwd = `pwd`) if $pwd eq '';
  1351. X    (chdir $olddir) || die "Directory $olddir is not accesible";
  1352. X    }
  1353. X    unless ($olddir eq '.deleted') {
  1354. X    if (-d '.deleted') {
  1355. X        chdir '.deleted' || die "Directory .deleted is not accesible";
  1356. X    }
  1357. X    else {
  1358. X        chop($pwd = `pwd`) if $pwd eq '';
  1359. X        die "Directory .deleted does not exist" unless $pwd =~ /\.deleted$/;
  1360. X    }
  1361. X    }
  1362. X    print `mv $startfiles$filelist..$force`;
  1363. X    if ($olddir ne '.') {
  1364. X    (chdir $pwd) || die "Can't get back to original directory $pwd: $!\n";
  1365. X    }
  1366. X}
  1367. X
  1368. Xif ($#ARGV < 0) {
  1369. X    open(lastcmd,'.deleted/.lastcmd') || 
  1370. X    open(lastcmd,'.lastcmd') || 
  1371. X        die "No previous vanish in this dir";
  1372. X    $ARGV = <lastcmd>;
  1373. X    close(lastcmd);
  1374. X    @ARGV = split(/[\n ]+/,$ARGV);
  1375. X}
  1376. X
  1377. Xwhile ($ARGV[0] =~ /^-/) {
  1378. X    $_ = shift;
  1379. X    /^-f/ && ($force = ' >/dev/null 2>&1');
  1380. X    /^-i/ && ($interactive = 1);
  1381. X    if (/^-+$/) {
  1382. X    $startfiles = '- ';
  1383. X    last;
  1384. X    }
  1385. X}
  1386. X
  1387. Xwhile ($file = shift) {
  1388. X    if ($file =~ s|^(.*)/||) {
  1389. X    $dir = $1;
  1390. X    }
  1391. X    else {
  1392. X    $dir = '.';
  1393. X    }
  1394. X
  1395. X    if ($dir ne $olddir) {
  1396. X    do it() if $olddir;
  1397. X    $olddir = $dir;
  1398. X    }
  1399. X
  1400. X    if ($interactive) {
  1401. X    print "unvanish: restore $dir/$file? ";
  1402. X    next unless <stdin> =~ /^y/i;
  1403. X    }
  1404. X
  1405. X    $filelist .= $file; $filelist .= ' ';
  1406. X
  1407. X}
  1408. X
  1409. Xdo it() if $olddir;
  1410. !STUFFY!FUNK!
  1411. echo Extracting cflags.SH
  1412. sed >cflags.SH <<'!STUFFY!FUNK!' -e 's/X//'
  1413. Xcase $CONFIG in
  1414. X'')
  1415. X    if test ! -f config.sh; then
  1416. X    ln ../config.sh . || \
  1417. X    ln ../../config.sh . || \
  1418. X    ln ../../../config.sh . || \
  1419. X    (echo "Can't find config.sh."; exit 1)
  1420. X    fi 2>/dev/null
  1421. X    . ./config.sh
  1422. X    ;;
  1423. Xesac
  1424. Xcase "$0" in
  1425. X*/*) cd `expr X$0 : 'X\(.*\)/'` ;;
  1426. Xesac
  1427. X
  1428. Xalso=': '
  1429. Xcase $# in
  1430. X1) also='echo 1>&2 "      CFLAGS = "'
  1431. Xesac
  1432. X
  1433. Xcase $# in
  1434. X0) set *.c; echo "The current C flags are:" ;;
  1435. X*) set `echo "$* " | sed 's/\.o /.c /g'`
  1436. Xesac
  1437. Xfor file do
  1438. X
  1439. X    case "$#" in
  1440. X    1) ;;
  1441. X    *) echo $n "    $file    $c" ;;
  1442. X    esac
  1443. X
  1444. X    case "$file" in
  1445. X    array.c) ;;
  1446. X    cmd.c) ;;
  1447. X    cons.c) ;;
  1448. X    consarg.c) ;;
  1449. X    doarg.c) ;;
  1450. X    doio.c) ;;
  1451. X    dolist.c) ;;
  1452. X    dump.c) ;;
  1453. X    eval.c) ;;
  1454. X    form.c) ;;
  1455. X    hash.c) ;;
  1456. X    malloc.c) ;;
  1457. X    perl.c) ;;
  1458. X    perly.c) ;;
  1459. X    regcomp.c) ;;
  1460. X    regexec.c) ;;
  1461. X    stab.c) ;;
  1462. X    str.c) ;;
  1463. X    toke.c) ;;
  1464. X    usersub.c) ;;
  1465. X    util.c) ;;
  1466. X    tarray.c) ;;
  1467. X    tcmd.c) ;;
  1468. X    tcons.c) ;;
  1469. X    tconsarg.c) ;;
  1470. X    tdoarg.c) ;;
  1471. X    tdoio.c) ;;
  1472. X    tdolist.c) ;;
  1473. X    tdump.c) ;;
  1474. X    teval.c) ;;
  1475. X    tform.c) ;;
  1476. X    thash.c) ;;
  1477. X    tmalloc.c) ;;
  1478. X    tperl.c) ;;
  1479. X    tperly.c) ;;
  1480. X    tregcomp.c) ;;
  1481. X    tregexec.c) ;;
  1482. X    tstab.c) ;;
  1483. X    tstr.c) ;;
  1484. X    ttoke.c) ;;
  1485. X    tusersub.c) ;;
  1486. X    tutil.c) ;;
  1487. X    *) ;;
  1488. X    esac
  1489. X
  1490. X    echo "$ccflags $optimize $large $split"
  1491. X    eval "$also $ccflags $optimize $large $split"
  1492. Xdone
  1493. !STUFFY!FUNK!
  1494. echo Extracting eg/van/vanish
  1495. sed >eg/van/vanish <<'!STUFFY!FUNK!' -e 's/X//'
  1496. X#!/usr/bin/perl
  1497. X
  1498. X# $Header: vanish,v 4.0 91/03/20 01:16:05 lwall Locked $
  1499. X
  1500. Xsub it {
  1501. X    if ($olddir ne '.') {
  1502. X    chop($pwd = `pwd`) if $pwd eq '';
  1503. X    (chdir $olddir) || die "Directory $olddir is not accesible";
  1504. X    }
  1505. X    if (!-d .deleted) {
  1506. X    print `mkdir .deleted; chmod 775 .deleted`;
  1507. X    die "You can't remove files from $olddir" if $?;
  1508. X    }
  1509. X    $filelist =~ s/ $//;
  1510. X    $filelist =~ s/#/\\#/g;
  1511. X    if ($filelist !~ /^[ \t]*$/) {
  1512. X    open(lastcmd,'>.deleted/.lastcmd');
  1513. X    print lastcmd $filelist,"\n";
  1514. X    close(lastcmd);
  1515. X    print `/bin/mv $startfiles$filelist .deleted$force`;
  1516. X    }
  1517. X    if ($olddir ne '.') {
  1518. X    (chdir $pwd) || die "Can't get back to original directory $pwd: $!\n";
  1519. X    }
  1520. X}
  1521. X
  1522. Xwhile ($ARGV[0] =~ /^-/) {
  1523. X    $_ = shift;
  1524. X    /^-f/ && ($force = ' >/dev/null 2>&1');
  1525. X    /^-i/ && ($interactive = 1);
  1526. X    if (/^-+$/) {
  1527. X    $startfiles = '- ';
  1528. X    last;
  1529. X    }
  1530. X}
  1531. X
  1532. Xchop($pwd = `pwd`);
  1533. X
  1534. Xwhile ($file = shift) {
  1535. X    if ($file =~ s|^(.*)/||) {
  1536. X    $dir = $1;
  1537. X    }
  1538. X    else {
  1539. X    $dir = '.';
  1540. X    }
  1541. X
  1542. X    if ($interactive) {
  1543. X    print "vanish: remove $dir/$file? ";
  1544. X    next unless <stdin> =~ /^y/i;
  1545. X    }
  1546. X
  1547. X    if ($file eq '.deleted') {
  1548. X    print stderr "To delete .deleted (the trashcan) use the 'empty' command.\n";
  1549. X    next;
  1550. X    }
  1551. X
  1552. X    if ($dir ne $olddir) {
  1553. X    do it() if $olddir;
  1554. X    $olddir = $dir;
  1555. X    }
  1556. X
  1557. X    $filelist .= $file; $filelist .= ' ';
  1558. X}
  1559. X
  1560. Xdo it() if $olddir;
  1561. !STUFFY!FUNK!
  1562. echo Extracting eg/scan/scan_df
  1563. sed >eg/scan/scan_df <<'!STUFFY!FUNK!' -e 's/X//'
  1564. X#!/usr/bin/perl -P
  1565. X
  1566. X# $Header: scan_df,v 4.0 91/03/20 01:12:28 lwall Locked $
  1567. X
  1568. X# This report points out filesystems that are in danger of overflowing.
  1569. X
  1570. X(chdir '/usr/adm/private/memories') || die "Can't cd to memories: $!\n";
  1571. X`df >newdf`;
  1572. Xopen(Df, 'olddf');
  1573. X
  1574. Xwhile (<Df>) {
  1575. X    ($fs,$kbytes,$used,$avail,$capacity,$mounted_on) = split;
  1576. X    next if $fs =~ /:/;
  1577. X    next if $fs eq '';
  1578. X    $oldused{$fs} = $used;
  1579. X}
  1580. X
  1581. Xopen(Df, 'newdf') || die "scan_df: can't open newdf";
  1582. X
  1583. Xwhile (<Df>) {
  1584. X    ($fs,$kbytes,$used,$avail,$capacity,$mounted_on) = split;
  1585. X    next if $fs =~ /:/;
  1586. X    next if $fs eq '';
  1587. X    $oldused = $oldused{$fs};
  1588. X    next if ($oldused == $used && $capacity < 99);    # inactive filesystem
  1589. X    if ($capacity >= 90) {
  1590. X#if defined(mc300) || defined(mc500) || defined(mc700)
  1591. X    $_ = substr($_,0,13) . '        ' . substr($_,13,1000);
  1592. X    $kbytes /= 2;        # translate blocks to K
  1593. X    $used /= 2;
  1594. X    $oldused /= 2;
  1595. X    $avail /= 2;
  1596. X#endif
  1597. X    $diff = int($used - $oldused);
  1598. X    if ($avail < $diff * 2) {    # mark specially if in danger
  1599. X        $mounted_on .= ' *';
  1600. X    }
  1601. X    next if $diff < 50 && $mounted_on eq '/';
  1602. X    $fs =~ s|/dev/||;
  1603. X    if ($diff >= 0) {
  1604. X        $diff = '(+' . $diff . ')';
  1605. X    }
  1606. X    else {
  1607. X        $diff = '(' . $diff . ')';
  1608. X    }
  1609. X    printf "%-8s%8d%8d %-8s%8d%7s    %s\n",
  1610. X        $fs,$kbytes,$used,$diff,$avail,$capacity,$mounted_on;
  1611. X    }
  1612. X}
  1613. X
  1614. Xrename('newdf','olddf');
  1615. !STUFFY!FUNK!
  1616. echo Extracting usub/man2mus
  1617. sed >usub/man2mus <<'!STUFFY!FUNK!' -e 's/X//'
  1618. X#!/usr/bin/perl
  1619. Xwhile (<>) {
  1620. X    if (/^\.SH SYNOPSIS/) {
  1621. X    $spec = '';
  1622. X    for ($_ = <>; $_ && !/^\.SH/; $_ = <>) {
  1623. X        s/^\.[IRB][IRB]\s*//;
  1624. X        s/^\.[IRB]\s+//;
  1625. X        next if /^\./;
  1626. X        s/\\f\w//g;
  1627. X        s/\\&//g;
  1628. X        s/^\s+//;
  1629. X        next if /^$/;
  1630. X        next if /^#/;
  1631. X        $spec .= $_;
  1632. X    }
  1633. X    $_ = $spec;
  1634. X    0 while s/\(([^),;]*)\s*,\s*([^);]*)\)/($1|$2)/g;
  1635. X    s/\(\*([^,;]*)\)\(\)/(*)()$1/g;
  1636. X    s/(\w+)\[\]/*$1/g;
  1637. X
  1638. X    s/\n/ /g;
  1639. X    s/\s+/ /g;
  1640. X    s/(\w+) \(([^*])/$1($2/g;
  1641. X    s/^ //;
  1642. X    s/ ?; ?/\n/g;
  1643. X    s/\) /)\n/g;
  1644. X    s/ \* / \*/g;
  1645. X    s/\* / \*/g;
  1646. X
  1647. X    $* = 1;
  1648. X    0 while s/^((struct )?\w+ )([^\n,]*), ?(.*)/$1$3\n$1$4/g;
  1649. X    $* = 0;
  1650. X    s/\|/,/g;
  1651. X
  1652. X    @cases = ();
  1653. X    for (reverse split(/\n/,$_)) {
  1654. X        if (/\)$/) {
  1655. X        ($type,$name,$args) = split(/(\w+)\(/);
  1656. X        $type =~ s/ $//;
  1657. X        if ($type =~ /^(\w+) =/) {
  1658. X            $type = $type{$1} if $type{$1};
  1659. X        }
  1660. X        $type = 'int' if $type eq '';
  1661. X        @args = grep(/./, split(/[,)]/,$args));
  1662. X        $case = "CASE $type $name\n";
  1663. X        foreach $arg (@args) {
  1664. X            $type = $type{$arg} || "int";
  1665. X            $type =~ s/ //g;
  1666. X            $type .= "\t" if length($type) < 8;
  1667. X            if ($type =~ /\*/) {
  1668. X            $case .= "IO    $type    $arg\n";
  1669. X            }
  1670. X            else {
  1671. X            $case .= "I    $type    $arg\n";
  1672. X            }
  1673. X        }
  1674. X        $case .= "END\n\n";
  1675. X        unshift(@cases, $case);
  1676. X        }
  1677. X        else {
  1678. X        $type{$name} = $type if ($type,$name) = /(.*\W)(\w+)$/;
  1679. X        }
  1680. X    }
  1681. X    print @cases;
  1682. X    }
  1683. X}
  1684. !STUFFY!FUNK!
  1685. echo Extracting makedir.SH
  1686. sed >makedir.SH <<'!STUFFY!FUNK!' -e 's/X//'
  1687. Xcase $CONFIG in
  1688. X'')
  1689. X    if test ! -f config.sh; then
  1690. X    ln ../config.sh . || \
  1691. X    ln ../../config.sh . || \
  1692. X    ln ../../../config.sh . || \
  1693. X    (echo "Can't find config.sh."; exit 1)
  1694. X    fi 2>/dev/null
  1695. X    . ./config.sh
  1696. X    ;;
  1697. Xesac
  1698. Xcase "$0" in
  1699. X*/*) cd `expr X$0 : 'X\(.*\)/'` ;;
  1700. Xesac
  1701. Xecho "Extracting makedir (with variable substitutions)"
  1702. X$spitshell >makedir <<!GROK!THIS!
  1703. X$startsh
  1704. X# $Header: makedir.SH,v 4.0 91/03/20 01:27:13 lwall Locked $
  1705. X# 
  1706. X# $Log:    makedir.SH,v $
  1707. X# Revision 4.0  91/03/20  01:27:13  lwall
  1708. X# 4.0 baseline.
  1709. X# 
  1710. X# 
  1711. X
  1712. Xexport PATH || (echo "OOPS, this isn't sh.  Desperation time.  I will feed myself to sh."; sh \$0; kill \$\$)
  1713. X
  1714. Xcase \$# in
  1715. X  0)
  1716. X    $echo "makedir pathname filenameflag"
  1717. X    exit 1
  1718. X    ;;
  1719. Xesac
  1720. X
  1721. X: guarantee one slash before 1st component
  1722. Xcase \$1 in
  1723. X  /*) ;;
  1724. X  *)  set ./\$1 \$2 ;;
  1725. Xesac
  1726. X
  1727. X: strip last component if it is to be a filename
  1728. Xcase X\$2 in
  1729. X  X1) set \`$echo \$1 | $sed 's:\(.*\)/[^/]*\$:\1:'\` ;;
  1730. X  *)  set \$1 ;;
  1731. Xesac
  1732. X
  1733. X: return reasonable status if nothing to be created
  1734. Xif $test -d "\$1" ; then
  1735. X    exit 0
  1736. Xfi
  1737. X
  1738. Xlist=''
  1739. Xwhile true ; do
  1740. X    case \$1 in
  1741. X    */*)
  1742. X    list="\$1 \$list"
  1743. X    set \`echo \$1 | $sed 's:\(.*\)/:\1 :'\`
  1744. X    ;;
  1745. X    *)
  1746. X    break
  1747. X    ;;
  1748. X    esac
  1749. Xdone
  1750. X
  1751. Xset \$list
  1752. X
  1753. Xfor dir do
  1754. X    $mkdir \$dir >/dev/null 2>&1
  1755. Xdone
  1756. X!GROK!THIS!
  1757. X$eunicefix makedir
  1758. Xchmod +x makedir
  1759. !STUFFY!FUNK!
  1760. echo Extracting eg/scan/scan_last
  1761. sed >eg/scan/scan_last <<'!STUFFY!FUNK!' -e 's/X//'
  1762. X#!/usr/bin/perl -P
  1763. X
  1764. X# $Header: scan_last,v 4.0 91/03/20 01:12:45 lwall Locked $
  1765. X
  1766. X# This reports who was logged on at weird hours
  1767. X
  1768. X($dy, $mo, $lastdt) = split(/ +/,`date`);
  1769. X
  1770. Xopen(Last, 'exec last 2>&1 |') || die "scan_last: can't run last";
  1771. X
  1772. Xwhile (<Last>) {
  1773. X#if defined(mc300) || defined(mc500) || defined(mc700)
  1774. X    $_ = substr($_,0,19) . substr($_,23,100);
  1775. X#endif
  1776. X    next if /^$/;
  1777. X    (print),next if m|^/|;
  1778. X    $login  = substr($_,0,8);
  1779. X    $tty    = substr($_,10,7);
  1780. X    $from   = substr($_,19,15);
  1781. X    $day    = substr($_,36,3);
  1782. X    $mo     = substr($_,40,3);
  1783. X    $dt     = substr($_,44,2);
  1784. X    $hr     = substr($_,47,2);
  1785. X    $min    = substr($_,50,2);
  1786. X    $dash   = substr($_,53,1);
  1787. X    $tohr   = substr($_,55,2);
  1788. X    $tomin  = substr($_,58,2);
  1789. X    $durhr  = substr($_,63,2);
  1790. X    $durmin = substr($_,66,2);
  1791. X    
  1792. X    next unless $hr;
  1793. X    next if $login eq 'reboot  ';
  1794. X    next if $login eq 'shutdown';
  1795. X
  1796. X    if ($dt != $lastdt) {
  1797. X    if ($lastdt < $dt) {
  1798. X        $seen += $dt - $lastdt;
  1799. X    }
  1800. X    else {
  1801. X        $seen++;
  1802. X    }
  1803. X    $lastdt = $dt;
  1804. X    }
  1805. X
  1806. X    $inat = $hr + $min / 60;
  1807. X    if ($tohr =~ /^[a-z]/) {
  1808. X    $outat = 12;        # something innocuous
  1809. X    } else {
  1810. X    $outat = $tohr + $tomin / 60;
  1811. X    }
  1812. X
  1813. X  last if $seen + ($inat < 8) > 1;
  1814. X
  1815. X    if ($inat < 5 || $inat > 21 || $outat < 6 || $outat > 23) {
  1816. X    print;
  1817. X    }
  1818. X}
  1819. !STUFFY!FUNK!
  1820. echo Extracting x2p/hash.h
  1821. sed >x2p/hash.h <<'!STUFFY!FUNK!' -e 's/X//'
  1822. X/* $Header: hash.h,v 4.0 91/03/20 01:57:53 lwall Locked $
  1823. X *
  1824. X *    Copyright (c) 1989, Larry Wall
  1825. X *
  1826. X *    You may distribute under the terms of the GNU General Public License
  1827. X *    as specified in the README file that comes with the perl 3.0 kit.
  1828. X *
  1829. X * $Log:    hash.h,v $
  1830. X * Revision 4.0  91/03/20  01:57:53  lwall
  1831. X * 4.0 baseline.
  1832. X * 
  1833. X */
  1834. X
  1835. X#define FILLPCT 60        /* don't make greater than 99 */
  1836. X
  1837. X#ifdef DOINIT
  1838. Xchar coeff[] = {
  1839. X        61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1,
  1840. X        61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1,
  1841. X        61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1,
  1842. X        61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1,
  1843. X        61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1,
  1844. X        61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1,
  1845. X        61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1,
  1846. X        61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1};
  1847. X#else
  1848. Xextern char coeff[];
  1849. X#endif
  1850. X
  1851. Xtypedef struct hentry HENT;
  1852. X
  1853. Xstruct hentry {
  1854. X    HENT    *hent_next;
  1855. X    char    *hent_key;
  1856. X    STR        *hent_val;
  1857. X    int        hent_hash;
  1858. X};
  1859. X
  1860. Xstruct htbl {
  1861. X    HENT    **tbl_array;
  1862. X    int        tbl_max;
  1863. X    int        tbl_fill;
  1864. X    int        tbl_riter;    /* current root of iterator */
  1865. X    HENT    *tbl_eiter;    /* current entry of iterator */
  1866. X};
  1867. X
  1868. XSTR *hfetch();
  1869. Xbool hstore();
  1870. Xbool hdelete();
  1871. XHASH *hnew();
  1872. Xint hiterinit();
  1873. XHENT *hiternext();
  1874. Xchar *hiterkey();
  1875. XSTR *hiterval();
  1876. !STUFFY!FUNK!
  1877. echo Extracting t/comp/term.t
  1878. sed >t/comp/term.t <<'!STUFFY!FUNK!' -e 's/X//'
  1879. X#!./perl
  1880. X
  1881. X# $Header: term.t,v 4.0 91/03/20 01:50:36 lwall Locked $
  1882. X
  1883. X# tests that aren't important enough for base.term
  1884. X
  1885. Xprint "1..14\n";
  1886. X
  1887. X$x = "\\n";
  1888. Xprint "#1\t:$x: eq " . ':\n:' . "\n";
  1889. Xif ($x eq '\n') {print "ok 1\n";} else {print "not ok 1\n";}
  1890. X
  1891. X$x = "#2\t:$x: eq :\\n:\n";
  1892. Xprint $x;
  1893. Xunless (index($x,'\\\\')>0) {print "ok 2\n";} else {print "not ok 2\n";}
  1894. X
  1895. Xif (length('\\\\') == 2) {print "ok 3\n";} else {print "not ok 3\n";}
  1896. X
  1897. X$one = 'a';
  1898. X
  1899. Xif (length("\\n") == 2) {print "ok 4\n";} else {print "not ok 4\n";}
  1900. Xif (length("\\\n") == 2) {print "ok 5\n";} else {print "not ok 5\n";}
  1901. Xif (length("$one\\n") == 3) {print "ok 6\n";} else {print "not ok 6\n";}
  1902. Xif (length("$one\\\n") == 3) {print "ok 7\n";} else {print "not ok 7\n";}
  1903. Xif (length("\\n$one") == 3) {print "ok 8\n";} else {print "not ok 8\n";}
  1904. Xif (length("\\\n$one") == 3) {print "ok 9\n";} else {print "not ok 9\n";}
  1905. Xif (length("\\${one}") == 2) {print "ok 10\n";} else {print "not ok 10\n";}
  1906. X
  1907. Xif ("${one}b" eq "ab") { print "ok 11\n";} else {print "not ok 11\n";}
  1908. X
  1909. X@foo = (1,2,3);
  1910. Xif ("$foo[1]b" eq "2b") { print "ok 12\n";} else {print "not ok 12\n";}
  1911. Xif ("@foo[0..1]b" eq "1 2b") { print "ok 13\n";} else {print "not ok 13\n";}
  1912. X$" = '::';
  1913. Xif ("@foo[0..1]b" eq "1::2b") { print "ok 14\n";} else {print "not ok 14\n";}
  1914. !STUFFY!FUNK!
  1915. echo Extracting os2/glob.c
  1916. sed >os2/glob.c <<'!STUFFY!FUNK!' -e 's/X//'
  1917. X/*
  1918. X * Globbing for OS/2.  Relies on the expansion done by the library
  1919. X * startup code. (dds)
  1920. X */
  1921. X
  1922. X#include <stdio.h>
  1923. X#include <string.h>
  1924. X
  1925. Xmain(int argc, char *argv[])
  1926. X{
  1927. X  register i;
  1928. X
  1929. X  for (i = 1; i < argc; i++)
  1930. X  {
  1931. X    fputs(IsFileSystemFAT(argv[i]) ? strlwr(argv[i]) : argv[i], stdout);
  1932. X    putchar(0);
  1933. X  }
  1934. X}
  1935. !STUFFY!FUNK!
  1936. echo " "
  1937. echo "End of kit 34 (of 36)"
  1938. cat /dev/null >kit34isdone
  1939. run=''
  1940. config=''
  1941. 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
  1942.     if test -f kit${iskit}isdone; then
  1943.     run="$run $iskit"
  1944.     else
  1945.     todo="$todo $iskit"
  1946.     fi
  1947. done
  1948. case $todo in
  1949.     '')
  1950.     echo "You have run all your kits.  Please read README and then type Configure."
  1951.     for combo in *:AA; do
  1952.         if test -f "$combo"; then
  1953.         realfile=`basename $combo :AA`
  1954.         cat $realfile:[A-Z][A-Z] >$realfile
  1955.         rm -rf $realfile:[A-Z][A-Z]
  1956.         fi
  1957.     done
  1958.     rm -rf kit*isdone
  1959.     chmod 755 Configure
  1960.     ;;
  1961.     *)  echo "You have run$run."
  1962.     echo "You still need to run$todo."
  1963.     ;;
  1964. esac
  1965. : Someone might mail this, so...
  1966. exit
  1967.  
  1968. exit 0 # Just in case...
  1969. -- 
  1970. Kent Landfield                   INTERNET: kent@sparky.IMD.Sterling.COM
  1971. Sterling Software, IMD           UUCP:     uunet!sparky!kent
  1972. Phone:    (402) 291-8300         FAX:      (402) 291-4362
  1973. Please send comp.sources.misc-related mail to kent@uunet.uu.net.
  1974.