home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / languages / perl / scripts-osu / find2perl.shar < prev    next >
Encoding:
Internet Message Format  |  1991-03-06  |  15.3 KB
  1. Path: tut.cis.ohio-state.edu!pacific.mps.ohio-state.edu!zaphod.mps.ohio-state.edu!usc!elroy.jpl.nasa.gov!jpl-devvax!lwall
  2. From: lwall@jpl-devvax.JPL.NASA.GOV (Larry Wall)
  3. Newsgroups: comp.lang.perl
  4. Subject: Re: find2perl
  5. Message-ID: <11709@jpl-devvax.JPL.NASA.GOV>
  6. Date: 7 Mar 91 02:27:36 GMT
  7. References: <11674@jpl-devvax.JPL.NASA.GOV> <40887@genrad.UUCP>
  8. Reply-To: lwall@jpl-devvax.JPL.NASA.GOV (Larry Wall)
  9. Organization: Jet Propulsion Laboratory, Pasadena, CA
  10. Lines: 675
  11.  
  12. In article <40887@genrad.UUCP> rep@thor.genrad.COM (Pete Peterson) writes:
  13. : In article <11674@jpl-devvax.JPL.NASA.GOV> lwall@jpl-devvax.JPL.NASA.GOV (Larry Wall) writes:
  14. :  >This is an alpha version of find2perl.  It spits out a perl script that
  15. :  >does the same thing (hopefully) as the corresponding find command.
  16. :  >
  17. :  >Usage:
  18. :  >
  19. :  >    find2perl . -name '*.bak' -print | perl
  20. :  >
  21. :  >This isn't thoroughly tested.  It does do -print0 and -eval.  It doesn't
  22. :  >do -ls or -cpio (yet).  It does try pretty hard to avoid unnecessary
  23. :  >stats.
  24. : 
  25. : OK, I give up.  I'll ask the dumb question.  Why does it do:
  26. :             $pat = "*$pat*" unless $pat =~ tr/?*[//;
  27. : 
  28. : thus changing "find2perl . -name 'core'" into "find2perl . -name '*core*'"? 
  29.  
  30. Not a dumb question at all.  I misread the man page, and got confused by
  31. a feature that only applies to "fast find".
  32.  
  33. I've fixed that, and added -depth, -ls, -cpio, -ncpio and -tar.  So you
  34. can call this a beta.
  35.  
  36. I didn't realize till now just how much random crap tar and cpio leave sitting
  37. around in their output files...
  38.  
  39. BTW, Sun's find -cpio sets the inode number of a directory wrong, though
  40. it's probable that no one actually looks at it.
  41.  
  42. Larry
  43.  
  44. #!/bin/sh
  45. : make a subdirectory, cd to it, and run this through sh.
  46. echo 'If this kit is complete, "End of kit" will echo at the end'
  47. echo Extracting find2perl
  48. sed >find2perl <<'!STUFFY!FUNK!' -e 's/X//'
  49. X#!/usr/bin/perl
  50. X
  51. Xwhile ($ARGV[0] =~ /^[^-(]/) {
  52. X    push(@roots, shift);
  53. X}
  54. X@roots = ('.') unless @roots;
  55. Xfor (@roots) { $_ = "e($_); }
  56. X$roots = join(',', @roots);
  57. X
  58. X$indent = 1;
  59. X
  60. Xwhile (@ARGV) {
  61. X    $_ = shift;
  62. X    if ($_ eq '(') {
  63. X    $out .= &tab . "(\n";
  64. X    $indent++;
  65. X    next;
  66. X    }
  67. X    elsif ($_ eq ')') {
  68. X    $indent--;
  69. X    $out .= &tab . ")";
  70. X    }
  71. X    elsif ($_ eq '!') {
  72. X    $out .= &tab . "!";
  73. X    next;
  74. X    }
  75. X    else {
  76. X    s/^-// || die "Unrecognized switch: $_\n";
  77. X    }
  78. X    if ($_ eq 'name') {
  79. X    $out .= &tab;
  80. X    $pat = &fileglob_to_re(shift);
  81. X    $out .= '/' . $pat . "/";
  82. X    }
  83. X    elsif ($_ eq 'perm') {
  84. X    $onum = shift;
  85. X    die "Malformed -perm argument: $onum\n" unless $onum =~ /^-?[0-7]+$/;
  86. X    if ($onum =~ s/^-//) {
  87. X        $onum = '0' . sprintf("%o", oct($onum) & 017777);    # s/b 07777 ?
  88. X        $out .= &tab . "(\$mode & $onum) == $onum";
  89. X    }
  90. X    else {
  91. X        $onum = '0' . $onum unless $onum =~ /^0/;
  92. X        $out .= &tab . "(\$mode & 0777) == $onum";
  93. X    }
  94. X    }
  95. X    elsif ($_ eq 'type') {
  96. X    ($filetest = shift) =~ tr/s/S/;
  97. X    $out .= &tab . "-$filetest _";
  98. X    }
  99. X    elsif ($_ eq 'print') {
  100. X    $out .= &tab . 'print("$name\n")';
  101. X    }
  102. X    elsif ($_ eq 'print0') {
  103. X    $out .= &tab . 'print("$name\0")';
  104. X    }
  105. X    elsif ($_ eq 'fstype') {
  106. X    $out .= &tab;
  107. X    $type = shift;
  108. X    if ($type eq 'nfs')
  109. X        { $out .= '$dev < 0'; }
  110. X    else
  111. X        { $out .= '$dev >= 0'; }
  112. X    }
  113. X    elsif ($_ eq 'user') {
  114. X    $uname = shift;
  115. X    $out .= &tab . "\$uid == \$uid{'$uname'}";
  116. X    $inituser++;
  117. X    }
  118. X    elsif ($_ eq 'group') {
  119. X    $gname = shift;
  120. X    $out .= &tab . "\$gid == \$gid('$gname')";
  121. X    $initgroup++;
  122. X    }
  123. X    elsif ($_ eq 'nouser') {
  124. X    $out .= &tab . '!defined $uid{$uid}';
  125. X    $inituser++;
  126. X    }
  127. X    elsif ($_ eq 'nogroup') {
  128. X    $out .= &tab . '!defined $gid{$gid}';
  129. X    $initgroup++;
  130. X    }
  131. X    elsif ($_ eq 'links') {
  132. X    $out .= &tab . '$nlink ' . &n(shift);
  133. X    }
  134. X    elsif ($_ eq 'inum') {
  135. X    $out .= &tab . '$ino ' . &n(shift);
  136. X    }
  137. X    elsif ($_ eq 'size') {
  138. X    $out .= &tab . 'int((-s _ + 511) / 512) ' . &n(shift);
  139. X    }
  140. X    elsif ($_ eq 'atime') {
  141. X    $out .= &tab . 'int(-A _) ' . &n(shift);
  142. X    }
  143. X    elsif ($_ eq 'mtime') {
  144. X    $out .= &tab . 'int(-M _) ' . &n(shift);
  145. X    }
  146. X    elsif ($_ eq 'ctime') {
  147. X    $out .= &tab . 'int(-C _) ' . &n(shift);
  148. X    }
  149. X    elsif ($_ eq 'exec') {
  150. X    for (@cmd = (); @ARGV && $ARGV[0] ne ';'; push(@cmd,shift)) { }
  151. X    shift;
  152. X    for (@cmd) { s/'/\\'/g; }
  153. X    $" = "','";
  154. X    $out .= &tab . "&exec(0, '@cmd')";
  155. X    $" = ' ';
  156. X    $initexec++;
  157. X    }
  158. X    elsif ($_ eq 'ok') {
  159. X    for (@cmd = (); @ARGV && $ARGV[0] ne ';'; push(@cmd,shift)) { }
  160. X    shift;
  161. X    for (@cmd) { s/'/\\'/g; }
  162. X    $" = "','";
  163. X    $out .= &tab . "&exec(1, '@cmd')";
  164. X    $" = ' ';
  165. X    $initexec++;
  166. X    }
  167. X    elsif ($_ eq 'prune') {
  168. X    $out .= &tab . '($prune = 1)';
  169. X    }
  170. X    elsif ($_ eq 'xdev') {
  171. X    $out .= &tab . '(($prune |= ($dev != $topdev)),1)';
  172. X    }
  173. X    elsif ($_ eq 'newer') {
  174. X    $out .= &tab;
  175. X    $file = shift;
  176. X    $newername = 'AGE_OF' . $file;
  177. X    $newername =~ s/[^\w]/_/g;
  178. X    $newername = '$' . $newername;
  179. X    $out .= "-M _ < $newername";
  180. X    $initnewer .= "$newername = -M " . "e($file) . ";\n";
  181. X    }
  182. X    elsif ($_ eq 'eval') {
  183. X    $prog = "e(shift);
  184. X    $out .= &tab . "eval $prog";
  185. X    }
  186. X    elsif ($_ eq 'depth') {
  187. X    $depth++;
  188. X    next;
  189. X    }
  190. X    elsif ($_ eq 'ls') {
  191. X    $out .= &tab . "&ls";
  192. X    $initls++;
  193. X    }
  194. X    elsif ($_ eq 'tar') {
  195. X    $out .= &tab;
  196. X    die "-tar must have a filename argument\n" unless @ARGV;
  197. X    $file = shift;
  198. X    $fh = 'FH' . $file;
  199. X    $fh =~ s/[^\w]/_/g;
  200. X    $out .= "&tar($fh)";
  201. X    $file = '>' . $file;
  202. X    $initfile .= "open($fh, " . "e($file) .
  203. X      qq{) || die "Can't open $fh: \$!\\n";\n};
  204. X    $inittar++;
  205. X    $flushall = "\n&tflushall;\n";
  206. X    }
  207. X    elsif (/^n?cpio$/) {
  208. X    $depth++;
  209. X    $out .= &tab;
  210. X    die "-$_ must have a filename argument\n" unless @ARGV;
  211. X    $file = shift;
  212. X    $fh = 'FH' . $file;
  213. X    $fh =~ s/[^\w]/_/g;
  214. X    $out .= "&cpio('" . substr($_,0,1) . "', $fh)";
  215. X    $file = '>' . $file;
  216. X    $initfile .= "open($fh, " . "e($file) .
  217. X      qq{) || die "Can't open $fh: \$!\\n";\n};
  218. X    $initcpio++;
  219. X    $flushall = "\n&flushall;\n";
  220. X    }
  221. X    else {
  222. X    die "Unrecognized switch: -$_\n";
  223. X    }
  224. X    if (@ARGV) {
  225. X    if ($ARGV[0] eq '-o') {
  226. X        $out .= " ||\n";
  227. X        shift;
  228. X    }
  229. X    else {
  230. X        $out .= " &&" unless $ARGV[0] eq ')';
  231. X        $out .= "\n";
  232. X        shift if $ARGV[0] eq '-a';
  233. X    }
  234. X    }
  235. X}
  236. X
  237. Xprint <<'END';
  238. X#!/usr/bin/perl
  239. X
  240. XEND
  241. X
  242. Xif ($initls) {
  243. X    print <<'END';
  244. X@rwx = ('---','--x','-w-','-wx','r--','r-x','rw-','rwx');
  245. X@moname = (Jan,Feb,Mar,Apr,May,Jun,Jul,Aug,Sep,Oct,Nov,Dec);
  246. X
  247. XEND
  248. X}
  249. X
  250. Xif ($inituser || $initls) {
  251. X    print 'while (($name, $pw, $uid) = getpwent) {', "\n";
  252. X    print '    $uid{$name} = $uid{$uid} = $uid;', "\n" if $inituser;
  253. X    print '    $user{$uid} = $name unless $user{$uid};', "\n" if $initls;
  254. X    print "}\n\n";
  255. X}
  256. X
  257. Xif ($initgroup || $initls) {
  258. X    print 'while (($name, $pw, $gid) = getgrent) {', "\n";
  259. X    print '    $gid{$name} = $gid{$gid} = $gid;', "\n" if $initgroup;
  260. X    print '    $group{$gid} = $name unless $group{$gid};', "\n" if $initls;
  261. X    print "}\n\n";
  262. X}
  263. X
  264. Xprint $initnewer, "\n" if $initnewer;
  265. X
  266. Xprint $initfile, "\n" if $initfile;
  267. X
  268. Xprint <<"END";
  269. X# Traverse desired filesystems
  270. X
  271. X&dodirs($roots);
  272. X$flushall
  273. Xexit;
  274. X
  275. Xsub wanted {
  276. X$out;
  277. X}
  278. X
  279. XEND
  280. X
  281. Xprint <<'END';
  282. Xsub dodirs {
  283. X    chop($cwd = `pwd`);
  284. X    foreach $topdir (@_) {
  285. X    (($topdev,$topino,$topmode,$topnlink) = stat($topdir))
  286. X      || (warn("Can't stat $topdir: $!\n"), next);
  287. X    if (-d _) {
  288. X        if (chdir($topdir)) {
  289. XEND
  290. Xif ($depth) {
  291. X    print <<'END';
  292. X        $topdir = '' if $topdir eq '/';
  293. X        &dodir($topdir,$topnlink);
  294. X        ($dir,$_) = ($topdir,'.');
  295. X        $name = $topdir;
  296. X        &wanted;
  297. XEND
  298. X}
  299. Xelse {
  300. X    print <<'END';
  301. X        ($dir,$_) = ($topdir,'.');
  302. X        $name = $topdir;
  303. X        &wanted;
  304. X        $topdir = '' if $topdir eq '/';
  305. X        &dodir($topdir,$topnlink);
  306. XEND
  307. X}
  308. Xprint <<'END';
  309. X        }
  310. X        else {
  311. X        warn "Can't cd to $topdir: $!\n";
  312. X        }
  313. X    }
  314. X    else {
  315. X        unless (($dir,$_) = $topdir =~ m#^(.*/)(.*)$#) {
  316. X        ($dir,$_) = ('.', $topdir);
  317. X        }
  318. X        chdir $dir && &wanted;
  319. X    }
  320. X    chdir $cwd;
  321. X    }
  322. X}
  323. X
  324. Xsub dodir {
  325. X    local($dir,$nlink) = @_;
  326. X    local($dev,$ino,$mode,$subcount);
  327. X    local($name);
  328. X
  329. X    # Get the list of files in the current directory.
  330. X
  331. X    opendir(DIR,'.') || warn "Can't open $dir: $!\n";
  332. X    local(@filenames) = readdir(DIR);
  333. X    closedir(DIR);
  334. X
  335. X    if ($nlink == 2) {        # This dir has no subdirectories.
  336. X    for (@filenames) {
  337. X        next if $_ eq '.';
  338. X        next if $_ eq '..';
  339. X        $name = "$dir/$_";
  340. X        &wanted;
  341. X    }
  342. X    }
  343. X    else {                    # This dir has subdirectories.
  344. X    $subcount = $nlink - 2;
  345. X    for (@filenames) {
  346. X        next if $_ eq '.';
  347. X        next if $_ eq '..';
  348. X        $nlink = $prune = 0;
  349. X        $name = "$dir/$_";
  350. XEND
  351. Xprint <<'END' unless $depth;
  352. X        &wanted;
  353. XEND
  354. Xprint <<'END';
  355. X        if ($subcount > 0) {    # Seen all the subdirs?
  356. X
  357. X        # Get link count and check for directoriness.
  358. X
  359. X        ($dev,$ino,$mode,$nlink) = lstat($_) unless $nlink;
  360. X        
  361. X        if (-d _) {
  362. X
  363. X            # It really is a directory, so do it recursively.
  364. X
  365. X            if (!$prune && chdir $_) {
  366. X            &dodir($name,$nlink);
  367. X            chdir '..';
  368. X            }
  369. X            --$subcount;
  370. X        }
  371. X        }
  372. XEND
  373. Xprint <<'END' if $depth;
  374. X        &wanted;
  375. XEND
  376. Xprint <<'END';
  377. X    }
  378. X    }
  379. X}
  380. X
  381. XEND
  382. X
  383. Xif ($initexec) {
  384. X    print <<'END';
  385. Xsub exec {
  386. X    local($ok, @cmd) = @_;
  387. X    foreach $word (@cmd) {
  388. X    $word =~ s#{}#$name#g;
  389. X    }
  390. X    if ($ok) {
  391. X    local($old) = select(STDOUT);
  392. X    $| = 1;
  393. X    print "@cmd";
  394. X    select($old);
  395. X    return 0 unless <STDIN> =~ /^y/;
  396. X    }
  397. X    chdir $cwd;        # sigh
  398. X    system @cmd;
  399. X    chdir $dir;
  400. X    return !$?;
  401. X}
  402. X
  403. XEND
  404. X}
  405. X
  406. Xif ($initls) {
  407. X    print <<'END';
  408. Xsub ls {
  409. X    ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$sizemm,
  410. X      $atime,$mtime,$ctime,$blksize,$blocks) = lstat(_);
  411. X
  412. X    $pname = $name;
  413. X
  414. X    if (defined $blocks) {
  415. X    $blocks = int(($blocks + 1) / 2);
  416. X    }
  417. X    else {
  418. X    $blocks = int(($size + 1023) / 1024);
  419. X    }
  420. X
  421. X    if    (-f _) { $perms = '-'; }
  422. X    elsif (-d _) { $perms = 'd'; }
  423. X    elsif (-c _) { $perms = 'c'; $sizemm = &sizemm; }
  424. X    elsif (-b _) { $perms = 'b'; $sizemm = &sizemm; }
  425. X    elsif (-p _) { $perms = 'p'; }
  426. X    elsif (-S _) { $perms = 's'; }
  427. X    else         { $perms = 'l'; $pname .= ' -> ' . readlink($_); }
  428. X
  429. X    $tmpmode = $mode;
  430. X    $tmp = $rwx[$tmpmode & 7];
  431. X    $tmpmode >>= 3;
  432. X    $tmp = $rwx[$tmpmode & 7] . $tmp;
  433. X    $tmpmode >>= 3;
  434. X    $tmp = $rwx[$tmpmode & 7] . $tmp;
  435. X    substr($tmp,2,1) =~ tr/-x/Ss/ if -u _;
  436. X    substr($tmp,5,1) =~ tr/-x/Ss/ if -g _;
  437. X    substr($tmp,8,1) =~ tr/-x/Tt/ if -k _;
  438. X    $perms .= $tmp;
  439. X
  440. X    $user = $user{$uid} || $uid;
  441. X    $group = $group{$gid} || $gid;
  442. X
  443. X    ($sec,$min,$hour,$mday,$mon,$year) = localtime($mtime);
  444. X    $moname = $moname[$mon];
  445. X    if (-M _ > 365.25 / 2) {
  446. X    $timeyear = '19' . $year;
  447. X    }
  448. X    else {
  449. X    $timeyear = sprintf("%02d:%02d", $hour, $min);
  450. X    }
  451. X
  452. X    printf "%5lu %4ld %-10s %2d %-8s %-8s %8s %s %2d %5s %s\n",
  453. X        $ino,
  454. X         $blocks,
  455. X              $perms,
  456. X                $nlink,
  457. X                $user,
  458. X                     $group,
  459. X                      $sizemm,
  460. X                          $moname,
  461. X                         $mday,
  462. X                             $timeyear,
  463. X                             $pname;
  464. X    1;
  465. X}
  466. X
  467. Xsub sizemm {
  468. X    sprintf("%3d, %3d", ($rdev >> 8) & 255, $rdev & 255);
  469. X}
  470. X
  471. XEND
  472. X}
  473. X
  474. Xif ($initcpio) {
  475. Xprint <<'END';
  476. Xsub cpio {
  477. X    local($nc,$fh) = @_;
  478. X    local($text);
  479. X
  480. X    if ($name eq 'TRAILER!!!') {
  481. X    $text = '';
  482. X    $size = 0;
  483. X    }
  484. X    else {
  485. X    ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
  486. X      $atime,$mtime,$ctime,$blksize,$blocks) = lstat(_);
  487. X    if (-f _) {
  488. X        open(IN, $_) || do {
  489. X        warn "Couldn't open $name: $!\n";
  490. X        return;
  491. X        };
  492. X    }
  493. X    else {
  494. X        $text = readlink($_);
  495. X        $size = 0 unless defined $text;
  496. X    }
  497. X    }
  498. X
  499. X    ($nm = $name) =~ s#^\./##;
  500. X    $nc{$fh} = $nc;
  501. X    if ($nc eq 'n') {
  502. X    $cpout{$fh} .=
  503. X      sprintf("%06o%06o%06o%06o%06o%06o%06o%06o%011lo%06o%011lo%s\0",
  504. X        070707,
  505. X        $dev & 0777777,
  506. X        $ino & 0777777,
  507. X        $mode & 0777777,
  508. X        $uid & 0777777,
  509. X        $gid & 0777777,
  510. X        $nlink & 0777777,
  511. X        $rdev & 0177777,
  512. X        $mtime,
  513. X        length($nm)+1,
  514. X        $size,
  515. X        $nm);
  516. X    }
  517. X    else {
  518. X    $cpout{$fh} .= "\0" if length($cpout{$fh}) & 1;
  519. X    $cpout{$fh} .= pack("SSSSSSSSLSLa*",
  520. X        070707, $dev, $ino, $mode, $uid, $gid, $nlink, $rdev, $mtime,
  521. X        length($nm)+1, $size, $nm . (length($nm) & 1 ? "\0" : "\0\0"));
  522. X    }
  523. X    if ($text ne '') {
  524. X    $cpout{$fh} .= $text;
  525. X    }
  526. X    elsif ($size) {
  527. X    &flush($fh) while ($l = length($cpout{$fh})) >= 5120;
  528. X    while (sysread(IN, $cpout{$fh}, 5120 - $l, $l)) {
  529. X        &flush($fh);
  530. X        $l = length($cpout{$fh});
  531. X    }
  532. X    }
  533. X    close IN;
  534. X}
  535. X
  536. Xsub flush {
  537. X    local($fh) = @_;
  538. X
  539. X    while (length($cpout{$fh}) >= 5120) {
  540. X    syswrite($fh,$cpout{$fh},5120);
  541. X    ++$blocks{$fh};
  542. X    substr($cpout{$fh}, 0, 5120) = '';
  543. X    }
  544. X}
  545. X
  546. Xsub flushall {
  547. X    $name = 'TRAILER!!!';
  548. X    foreach $fh (keys %cpout) {
  549. X    &cpio($nc{$fh},$fh);
  550. X    $cpout{$fh} .= "0" x (5120 - length($cpout{$fh}));
  551. X    &flush($fh);
  552. X    print $blocks{$fh} * 10, " blocks\n";
  553. X    }
  554. X}
  555. X
  556. XEND
  557. X}
  558. X
  559. Xif ($inittar) {
  560. Xprint <<'END';
  561. Xsub tar {
  562. X    local($fh) = @_;
  563. X    local($linkname,$header,$l,$slop);
  564. X    local($linkflag) = "\0";
  565. X
  566. X    ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
  567. X      $atime,$mtime,$ctime,$blksize,$blocks) = lstat(_);
  568. X    $nm = $name;
  569. X    if ($nlink > 1) {
  570. X    if ($linkname = $linkseen{$fh,$dev,$ino}) {
  571. X        $linkflag = 1;
  572. X    }
  573. X    else {
  574. X        $linkseen{$fh,$dev,$ino} = $nm;
  575. X    }
  576. X    }
  577. X    if (-f _) {
  578. X    open(IN, $_) || do {
  579. X        warn "Couldn't open $name: $!\n";
  580. X        return;
  581. X    };
  582. X    $size = 0 if $linkflag ne "\0";
  583. X    }
  584. X    else {
  585. X    $linkname = readlink($_);
  586. X    $linkflag = 2 if defined $linkname;
  587. X    $nm .= '/' if -d _;
  588. X    $size = 0;
  589. X    }
  590. X
  591. X    $header = pack("a100a8a8a8a12a12a8a1a100",
  592. X    $nm,
  593. X    sprintf("%6o ", $mode & 0777),
  594. X    sprintf("%6o ", $uid & 0777777),
  595. X    sprintf("%6o ", $gid & 0777777),
  596. X    sprintf("%11o ", $size),
  597. X    sprintf("%11o ", $mtime),
  598. X    "        ",
  599. X    $linkflag,
  600. X    $linkname);
  601. X    $l = length($header) % 512;
  602. X    substr($header, 148, 6) = sprintf("%6o", unpack("%16C*", $header));
  603. X    substr($header, 154, 1) = "\0";  # blech
  604. X    $tarout{$fh} .= $header;
  605. X    $tarout{$fh} .= "\0" x (512 - $l) if $l;
  606. X    if ($size) {
  607. X    &tflush($fh) while ($l = length($tarout{$fh})) >= 10240;
  608. X    while (sysread(IN, $tarout{$fh}, 10240 - $l, $l)) {
  609. X        $slop = length($tarout{$fh}) % 512;
  610. X        $tarout{$fh} .= "\0" x (512 - $slop) if $slop;
  611. X        &tflush($fh);
  612. X        $l = length($tarout{$fh});
  613. X    }
  614. X    }
  615. X    close IN;
  616. X}
  617. X
  618. Xsub tflush {
  619. X    local($fh) = @_;
  620. X
  621. X    while (length($tarout{$fh}) >= 10240) {
  622. X    syswrite($fh,$tarout{$fh},10240);
  623. X    ++$blocks{$fh};
  624. X    substr($tarout{$fh}, 0, 10240) = '';
  625. X    }
  626. X}
  627. X
  628. Xsub tflushall {
  629. X    local($len);
  630. X
  631. X    foreach $fh (keys %tarout) {
  632. X    $len = 10240 - length($tarout{$fh});
  633. X    $len += 10240 if $len < 1024;
  634. X    $tarout{$fh} .= "\0" x $len;
  635. X    &tflush($fh);
  636. X    }
  637. X}
  638. X
  639. XEND
  640. X}
  641. X
  642. Xexit;
  643. X
  644. X############################################################################
  645. X
  646. Xsub tab {
  647. X    local($tabstring);
  648. X
  649. X    $tabstring = "\t" x ($indent / 2) . ' ' x ($indent % 2 * 4);
  650. X    if ($_ !~ /^(name|print)/) {
  651. X    if (!$statdone) {
  652. X        $tabstring .= <<'ENDOFSTAT' . $tabstring;
  653. X(($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_)) &&
  654. XENDOFSTAT
  655. X        $statdone = 1;
  656. X    }
  657. X    }
  658. X    $tabstring =~ s/^\s+/ / if $out =~ /!$/;
  659. X    $tabstring;
  660. X}
  661. X
  662. Xsub fileglob_to_re {
  663. X    local($tmp) = @_;
  664. X
  665. X    $tmp =~ s/([.^\$()])/\\$1/g;
  666. X    $tmp =~ s/([?*])/.$1/g;
  667. X    "^$tmp$";
  668. X}
  669. X
  670. Xsub n {
  671. X    local($n) = @_;
  672. X
  673. X    $n =~ s/^-0*/< / || $n =~ s/^\+0*/> / || $n =~ s/^0*/== /;
  674. X    $n;
  675. X}
  676. X
  677. Xsub quote {
  678. X    local($string) = @_;
  679. X    $string =~ s/'/\\'/;
  680. X    "'$string'";
  681. X}
  682. !STUFFY!FUNK!
  683. echo ""
  684. echo "End of kit"
  685. : I do not append .signature, but someone might mail this.
  686. exit
  687.  
  688.