source: trunk/third/perl/x2p/find2perl.PL @ 20075

Revision 20075, 24.3 KB checked in by zacheiss, 21 years ago (diff)
This commit was generated by cvs2svn to compensate for changes in r20074, which included commits to RCS files with non-trunk default branches.
Line 
1#!/usr/local/bin/perl
2
3use Config;
4use File::Basename qw(&basename &dirname);
5use Cwd;
6
7# List explicitly here the variables you want Configure to
8# generate.  Metaconfig only looks for shell variables, so you
9# have to mention them as if they were shell variables, not
10# %Config entries.  Thus you write
11#  $startperl
12# to ensure Configure will look for $Config{startperl}.
13
14# This forces PL files to create target in same directory as PL file.
15# This is so that make depend always knows where to find PL derivatives.
16$origdir = cwd;
17chdir dirname($0);
18$file = basename($0, '.PL');
19$file .= '.com' if $^O eq 'VMS';
20
21open OUT,">$file" or die "Can't create $file: $!";
22
23print "Extracting $file (with variable substitutions)\n";
24
25# In this section, perl variables will be expanded during extraction.
26# You can use $Config{...} to use Configure variables.
27
28print OUT <<"!GROK!THIS!";
29$Config{startperl}
30    eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}'
31      if \$running_under_some_shell;
32(my \$perlpath = <<'/../') =~ s/\\s*\\z//;
33$Config{perlpath}
34/../
35!GROK!THIS!
36
37# In the following, perl variables are not expanded during extraction.
38
39print OUT <<'!NO!SUBS!';
40use strict;
41use vars qw/$statdone/;
42use File::Spec::Functions 'curdir';
43my $startperl = "#! $perlpath -w";
44
45#
46# Modified September 26, 1993 to provide proper handling of years after 1999
47#   Tom Link <tml+@pitt.edu>
48#   University of Pittsburgh
49#
50# Modified April 7, 1998 with nasty hacks to implement the troublesome -follow
51#  Billy Constantine <wdconsta@cs.adelaide.edu.au> <billy@smug.adelaide.edu.au>
52#  University of Adelaide, Adelaide, South Australia
53#
54# Modified 1999-06-10, 1999-07-07 to migrate to cleaner perl5 usage
55#   Ken Pizzini <ken@halcyon.com>
56#
57# Modified 2000-01-28 to use the 'follow' option of File::Find
58
59sub tab ();
60sub n ($$);
61sub fileglob_to_re ($);
62sub quote ($);
63
64my @roots = ();
65while ($ARGV[0] =~ /^[^-!(]/) {
66    push(@roots, shift);
67}
68@roots = (curdir()) unless @roots;
69for (@roots) { $_ = quote($_) }
70my $roots = join(', ', @roots);
71
72my $find = "find";
73my $indent_depth = 1;
74my $stat = 'lstat';
75my $decl = '';
76my $flushall = '';
77my $initfile = '';
78my $initnewer = '';
79my $out = '';
80my $declaresubs = "sub wanted;\n";
81my %init = ();
82my ($follow_in_effect,$Skip_And) = (0,0);
83my $print_needed = 1;
84
85while (@ARGV) {
86    $_ = shift;
87    s/^-// || /^[()!]/ || die "Unrecognized switch: $_\n";
88    if ($_ eq '(') {
89        $out .= tab . "(\n";
90        $indent_depth++;
91        next;
92    } elsif ($_ eq ')') {
93        --$indent_depth;
94        $out .= tab . ")";
95    } elsif ($_ eq 'follow') {
96        $follow_in_effect= 1;
97        $stat = 'stat';
98        $Skip_And= 1;
99    } elsif ($_ eq '!') {
100        $out .= tab . "!";
101        next;
102    } elsif ($_ eq 'name') {
103        $out .= tab . '/' . fileglob_to_re(shift) . "/s";
104    } elsif ($_ eq 'perm') {
105        my $onum = shift;
106        $onum =~ /^-?[0-7]+$/
107            || die "Malformed -perm argument: $onum\n";
108        $out .= tab;
109        if ($onum =~ s/^-//) {
110            $onum = sprintf("0%o", oct($onum) & 07777);
111            $out .= "((\$mode & $onum) == $onum)";
112        } else {
113            $onum =~ s/^0*/0/;
114            $out .= "((\$mode & 0777) == $onum)";
115        }
116    } elsif ($_ eq 'type') {
117        (my $filetest = shift) =~ tr/s/S/;
118        $out .= tab . "-$filetest _";
119    } elsif ($_ eq 'print') {
120        $out .= tab . 'print("$name\n")';
121        $print_needed = 0;
122    } elsif ($_ eq 'print0') {
123        $out .= tab . 'print("$name\0")';
124        $print_needed = 0;
125    } elsif ($_ eq 'fstype') {
126        my $type = shift;
127        $out .= tab;
128        if ($type eq 'nfs') {
129            $out .= '($dev < 0)';
130        } else {
131            $out .= '($dev >= 0)'; #XXX
132        }
133    } elsif ($_ eq 'user') {
134        my $uname = shift;
135        $out .= tab . "(\$uid == \$uid{'$uname'})";
136        $init{user} = 1;
137    } elsif ($_ eq 'group') {
138        my $gname = shift;
139        $out .= tab . "(\$gid == \$gid{'$gname'})";
140        $init{group} = 1;
141    } elsif ($_ eq 'nouser') {
142        $out .= tab . '!exists $uid{$uid}';
143        $init{user} = 1;
144    } elsif ($_ eq 'nogroup') {
145        $out .= tab . '!exists $gid{$gid}';
146        $init{group} = 1;
147    } elsif ($_ eq 'links') {
148        $out .= tab . n('$nlink', shift);
149    } elsif ($_ eq 'inum') {
150        $out .= tab . n('$ino', shift);
151    } elsif ($_ eq 'size') {
152        $_ = shift;
153        my $n = 'int(((-s _) + 511) / 512)';
154        if (s/c\z//) {
155            $n = 'int(-s _)';
156        } elsif (s/k\z//) {
157            $n = 'int(((-s _) + 1023) / 1024)';
158        }
159        $out .= tab . n($n, $_);
160    } elsif ($_ eq 'atime') {
161        $out .= tab . n('int(-A _)', shift);
162    } elsif ($_ eq 'mtime') {
163        $out .= tab . n('int(-M _)', shift);
164    } elsif ($_ eq 'ctime') {
165        $out .= tab . n('int(-C _)', shift);
166    } elsif ($_ eq 'exec') {
167        my @cmd = ();
168        while (@ARGV && $ARGV[0] ne ';')
169            { push(@cmd, shift) }
170        shift;
171        $out .= tab;
172        if ($cmd[0] =~m#^(?:(?:/usr)?/bin/)?rm$#
173                && $cmd[$#cmd] eq '{}'
174                && (@cmd == 2 || (@cmd == 3 && $cmd[1] eq '-f'))) {
175            if (@cmd == 2) {
176                $out .= '(unlink($_) || warn "$name: $!\n")';
177            } elsif (!@ARGV) {
178                $out .= 'unlink($_)';
179            } else {
180                $out .= '(unlink($_) || 1)';
181            }
182        } else {
183            for (@cmd)
184                { s/'/\\'/g }
185            { local $" = "','"; $out .= "doexec(0, '@cmd')"; }
186            $declaresubs .= "sub doexec (\$\@);\n";
187            $init{doexec} = 1;
188        }
189        $print_needed = 0;
190    } elsif ($_ eq 'ok') {
191        my @cmd = ();
192        while (@ARGV && $ARGV[0] ne ';')
193            { push(@cmd, shift) }
194        shift;
195        $out .= tab;
196        for (@cmd)
197            { s/'/\\'/g }
198        { local $" = "','"; $out .= "doexec(1, '@cmd')"; }
199        $declaresubs .= "sub doexec (\$\@);\n";
200        $init{doexec} = 1;
201        $print_needed = 0;
202    } elsif ($_ eq 'prune') {
203        $out .= tab . '($File::Find::prune = 1)';
204    } elsif ($_ eq 'xdev') {
205        $out .= tab . '!($File::Find::prune |= ($dev != $File::Find::topdev))'
206;
207    } elsif ($_ eq 'newer') {
208        my $file = shift;
209        my $newername = 'AGE_OF' . $file;
210        $newername =~ s/\W/_/g;
211        $newername = '$' . $newername;
212        $out .= tab . "(-M _ < $newername)";
213        $initnewer .= "my $newername = -M " . quote($file) . ";\n";
214    } elsif ($_ eq 'eval') {
215        my $prog = shift;
216        $prog =~ s/'/\\'/g;
217        $out .= tab . "eval {$prog}";
218    } elsif ($_ eq 'depth') {
219        $find = 'finddepth';
220        next;
221    } elsif ($_ eq 'ls') {
222        $out .= tab . "ls";
223        $declaresubs .= "sub ls ();\n";
224        $init{ls} = 1;
225        $print_needed = 0;
226    } elsif ($_ eq 'tar') {
227        die "-tar must have a filename argument\n" unless @ARGV;
228        my $file = shift;
229        my $fh = 'FH' . $file;
230        $fh =~ s/\W/_/g;
231        $out .= tab . "tar(*$fh, \$name)";
232        $flushall .= "tflushall;\n";
233        $declaresubs .= "sub tar;\nsub tflushall ();\n";
234        $initfile .= "open($fh, " . quote('> ' . $file) .
235                     qq{) || die "Can't open $fh: \$!\\n";\n};
236        $init{tar} = 1;
237    } elsif (/^(n?)cpio\z/) {
238        die "-$_ must have a filename argument\n" unless @ARGV;
239        my $file = shift;
240        my $fh = 'FH' . $file;
241        $fh =~ s/\W/_/g;
242        $out .= tab . "cpio(*$fh, \$name, '$1')";
243        $find = 'finddepth';
244        $flushall .= "cflushall;\n";
245        $declaresubs .= "sub cpio;\nsub cflushall ();\n";
246        $initfile .= "open($fh, " . quote('> ' . $file) .
247                     qq{) || die "Can't open $fh: \$!\\n";\n};
248        $init{cpio} = 1;
249    } else {
250        die "Unrecognized switch: -$_\n";
251    }
252
253    if (@ARGV) {
254        if ($ARGV[0] eq '-o') {
255            { local($statdone) = 1; $out .= "\n" . tab . "||\n"; }
256            $statdone = 0 if $indent_depth == 1 && exists $init{delayedstat};
257            $init{saw_or} = 1;
258            shift;
259        } else {
260            $out .= " &&" unless $Skip_And || $ARGV[0] eq ')';
261            $out .= "\n";
262            shift if $ARGV[0] eq '-a';
263        }
264    }
265}
266
267if ($print_needed) {
268    $out .= "\n" . tab . '&& print("$name\n")';
269}
270
271
272print <<"END";
273$startperl
274    eval 'exec $perlpath -S \$0 \${1+"\$@"}'
275        if 0; #\$running_under_some_shell
276
277use strict;
278use File::Find ();
279
280# Set the variable \$File::Find::dont_use_nlink if you're using AFS,
281# since AFS cheats.
282
283# for the convenience of &wanted calls, including -eval statements:
284use vars qw/*name *dir *prune/;
285*name   = *File::Find::name;
286*dir    = *File::Find::dir;
287*prune  = *File::Find::prune;
288
289$declaresubs
290
291END
292
293if (exists $init{ls}) {
294    print <<'END';
295my @rwx = qw(--- --x -w- -wx r-- r-x rw- rwx);
296my @moname = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
297
298END
299}
300
301if (exists $init{user} || exists $init{ls} || exists $init{tar}) {
302    print "my (%uid, %user);\n";
303    print "while (my (\$name, \$pw, \$uid) = getpwent) {\n";
304    print '    $uid{$name} = $uid{$uid} = $uid;', "\n"
305        if exists $init{user};
306    print '    $user{$uid} = $name unless exists $user{$uid};', "\n"
307        if exists $init{ls} || exists $init{tar};
308    print "}\n\n";
309}
310
311if (exists $init{group} || exists $init{ls} || exists $init{tar}) {
312    print "my (%gid, %group);\n";
313    print "while (my (\$name, \$pw, \$gid) = getgrent) {\n";
314    print '    $gid{$name} = $gid{$gid} = $gid;', "\n"
315        if exists $init{group};
316    print '    $group{$gid} = $name unless exists $group{$gid};', "\n"
317        if exists $init{ls} || exists $init{tar};
318    print "}\n\n";
319}
320
321print $initnewer, "\n" if $initnewer ne '';
322print $initfile, "\n" if $initfile ne '';
323$flushall .= "exit;\n";
324if (exists $init{declarestat}) {
325    $out = <<'END' . $out;
326    my ($dev,$ino,$mode,$nlink,$uid,$gid);
327
328END
329}
330
331if ( $follow_in_effect ) {
332$out =~ s/lstat\(\$_\)/lstat(_)/;
333print <<"END";
334$decl
335# Traverse desired filesystems
336File::Find::$find( {wanted => \\&wanted, follow => 1}, $roots);
337$flushall
338
339sub wanted {
340$out;
341}
342
343END
344} else {
345print <<"END";
346$decl
347# Traverse desired filesystems
348File::Find::$find({wanted => \\&wanted}, $roots);
349$flushall
350
351sub wanted {
352$out;
353}
354
355END
356}
357
358if (exists $init{doexec}) {
359    print <<'END';
360
361use Cwd ();
362my $cwd = Cwd::cwd();
363
364sub doexec ($@) {
365    my $ok = shift;
366    my @command = @_; # copy so we don't try to s/// aliases to constants
367    for my $word (@command)
368        { $word =~ s#{}#$name#g }
369    if ($ok) {
370        my $old = select(STDOUT);
371        $| = 1;
372        print "@command";
373        select($old);
374        return 0 unless <STDIN> =~ /^y/;
375    }
376    chdir $cwd; #sigh
377    system @command;
378    chdir $File::Find::dir;
379    return !$?;
380}
381
382END
383}
384
385if (exists $init{ls}) {
386    print <<'INTRO', <<"SUB", <<'END';
387
388sub sizemm {
389    my $rdev = shift;
390    sprintf("%3d, %3d", ($rdev >> 8) & 0xff, $rdev & 0xff);
391}
392
393sub ls () {
394    my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
395INTRO
396        \$atime,\$mtime,\$ctime,\$blksize,\$blocks) = $stat(_);
397SUB
398    my $pname = $name;
399
400    $blocks
401        or $blocks = int(($size + 1023) / 1024);
402
403    my $perms = $rwx[$mode & 7];
404    $mode >>= 3;
405    $perms = $rwx[$mode & 7] . $perms;
406    $mode >>= 3;
407    $perms = $rwx[$mode & 7] . $perms;
408    substr($perms, 2, 1) =~ tr/-x/Ss/ if -u _;
409    substr($perms, 5, 1) =~ tr/-x/Ss/ if -g _;
410    substr($perms, 8, 1) =~ tr/-x/Tt/ if -k _;
411    if    (-f _) { $perms = '-' . $perms; }
412    elsif (-d _) { $perms = 'd' . $perms; }
413    elsif (-l _) { $perms = 'l' . $perms; $pname .= ' -> ' . readlink($_); }
414    elsif (-c _) { $perms = 'c' . $perms; $size = sizemm($rdev); }
415    elsif (-b _) { $perms = 'b' . $perms; $size = sizemm($rdev); }
416    elsif (-p _) { $perms = 'p' . $perms; }
417    elsif (-S _) { $perms = 's' . $perms; }
418    else         { $perms = '?' . $perms; }
419
420    my $user = $user{$uid} || $uid;
421    my $group = $group{$gid} || $gid;
422
423    my ($sec,$min,$hour,$mday,$mon,$timeyear) = localtime($mtime);
424    if (-M _ > 365.25 / 2) {
425        $timeyear += 1900;
426    } else {
427        $timeyear = sprintf("%02d:%02d", $hour, $min);
428    }
429
430    printf "%5lu %4ld %-10s %3d %-8s %-8s %8s %s %2d %5s %s\n",
431            $ino,
432                 $blocks,
433                      $perms,
434                            $nlink,
435                                $user,
436                                     $group,
437                                          $size,
438                                              $moname[$mon],
439                                                 $mday,
440                                                     $timeyear,
441                                                         $pname;
442    1;
443}
444
445END
446}
447
448
449if (exists $init{cpio} || exists $init{tar}) {
450print <<'END';
451
452my %blocks = ();
453
454sub flush {
455    my ($fh, $varref, $blksz) = @_;
456
457    while (length($$varref) >= $blksz) {
458        no strict qw/refs/;
459        syswrite($fh, $$varref, $blksz);
460        substr($$varref, 0, $blksz) = '';
461        ++$blocks{$fh};
462    }
463}
464
465END
466}
467
468
469if (exists $init{cpio}) {
470    print <<'INTRO', <<"SUB", <<'END';
471
472my %cpout = ();
473my %nc = ();
474
475sub cpio {
476    my ($fh, $fname, $nc) = @_;
477    my $text = '';
478    my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
479        $atime,$mtime,$ctime,$blksize,$blocks);
480    local (*IN);
481
482    if ( ! defined $fname ) {
483        $fname = 'TRAILER!!!';
484        ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
485          $atime,$mtime,$ctime,$blksize,$blocks) = (0) x 13;
486    } else {
487        ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
488INTRO
489          \$atime,\$mtime,\$ctime,\$blksize,\$blocks) = $stat(_);
490SUB
491        if (-f _) {
492            open(IN, "./$_\0") || do {
493                warn "Couldn't open $fname: $!\n";
494                return;
495            }
496        } else {
497            $text = readlink($_);
498            $size = 0 unless defined $text;
499        }
500    }
501
502    $fname =~ s#^\./##;
503    $nc{$fh} = $nc;
504    if ($nc eq 'n') {
505        $cpout{$fh} .=
506          sprintf("%06o%06o%06o%06o%06o%06o%06o%06o%011lo%06o%011lo%s\0",
507            070707,
508            $dev & 0777777,
509            $ino & 0777777,
510            $mode & 0777777,
511            $uid & 0777777,
512            $gid & 0777777,
513            $nlink & 0777777,
514            $rdev & 0177777,
515            $mtime,
516            length($fname)+1,
517            $size,
518            $fname);
519    } else {
520        $cpout{$fh} .= "\0" if length($cpout{$fh}) & 1;
521        $cpout{$fh} .= pack("SSSSSSSSLSLa*",
522            070707, $dev, $ino, $mode, $uid, $gid, $nlink, $rdev, $mtime,
523            length($fname)+1, $size,
524            $fname . (length($fname) & 1 ? "\0" : "\0\0"));
525    }
526
527    if ($text ne '') {
528        $cpout{$fh} .= $text;
529    } elsif ($size) {
530        my $l;
531        flush($fh, \$cpout{$fh}, 5120)
532            while ($l = length($cpout{$fh})) >= 5120;
533        while (sysread(IN, $cpout{$fh}, 5120 - $l, $l)) {
534            flush($fh, \$cpout{$fh}, 5120);
535            $l = length($cpout{$fh});
536        }
537        close IN;
538    }
539}
540
541sub cflushall () {
542    for my $fh (keys %cpout) {
543        cpio($fh, undef, $nc{$fh});
544        $cpout{$fh} .= "0" x (5120 - length($cpout{$fh}));
545        flush($fh, \$cpout{$fh}, 5120);
546        print $blocks{$fh} * 10, " blocks\n";
547    }
548}
549
550END
551}
552
553if (exists $init{tar}) {
554    print <<'INTRO', <<"SUB", <<'END';
555
556my %tarout = ();
557my %linkseen = ();
558
559sub tar {
560    my ($fh, $fname) = @_;
561    my $prefix = '';
562    my $typeflag = '0';
563    my $linkname;
564    my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
565INTRO
566        \$atime,\$mtime,\$ctime,\$blksize,\$blocks) = $stat(_);
567SUB
568    local (*IN);
569
570    if ($nlink > 1) {
571        if ($linkname = $linkseen{$fh, $dev, $ino}) {
572            if (length($linkname) > 100) {
573                warn "$0: omitting file with linkname ",
574                     "too long for tar output: $linkname\n";
575                return;
576            }
577            $typeflag = '1';
578            $size = 0;
579        } else {
580            $linkseen{$fh, $dev, $ino} = $fname;
581        }
582    }
583    if ($typeflag eq '0') {
584        if (-f _) {
585            open(IN, "./$_\0") || do {
586                warn "Couldn't open $fname: $!\n";
587                return;
588            }
589        } else {
590            $linkname = readlink($_);
591            if (defined $linkname) { $typeflag = '2' }
592            elsif (-c _) { $typeflag = '3' }
593            elsif (-b _) { $typeflag = '4' }
594            elsif (-d _) { $typeflag = '5' }
595            elsif (-p _) { $typeflag = '6' }
596        }
597    }
598
599    if (length($fname) > 100) {
600        ($prefix, $fname) = ($fname =~ m#\A(.*?)/(.{,100})\Z(?!\n)#);
601        if (!defined($fname) || length($prefix) > 155) {
602            warn "$0: omitting file with name too long for tar output: ",
603                 $fname, "\n";
604            return;
605        }
606    }
607
608    $size = 0 if $typeflag ne '0';
609    my $header = pack("a100a8a8a8a12a12a8a1a100a6a2a32a32a8a8a155",
610                        $fname,
611                        sprintf("%7o ", $mode &    0777),
612                        sprintf("%7o ", $uid  & 0777777),
613                        sprintf("%7o ", $gid  & 0777777),
614                        sprintf("%11o ", $size),
615                        sprintf("%11o ", $mtime),
616                        ' 'x8,
617                        $typeflag,
618                        defined $linkname ? $linkname : '',
619                        "ustar\0",
620                        "00",
621                        $user{$uid},
622                        $group{$gid},
623                        ($rdev >> 8) & 0xff,
624                        $rdev & 0xff,
625                        $prefix,
626                     );
627    substr($header, 148, 8) = sprintf("%7o ", unpack("%16C*", $header));
628    my $l = length($header) % 512;
629    $tarout{$fh} .= $header;
630    $tarout{$fh} .= "\0" x (512 - $l) if $l;
631
632    if ($size) {
633        flush($fh, \$tarout{$fh}, 10240)
634            while ($l = length($tarout{$fh})) >= 10240;
635        while (sysread(IN, $tarout{$fh}, 10240 - $l, $l)) {
636            my $slop = length($tarout{$fh}) % 512;
637            $tarout{$fh} .= "\0" x (512 - $slop) if $slop;
638            flush($fh, \$tarout{$fh}, 10240);
639            $l = length($tarout{$fh});
640        }
641        close IN;
642    }
643}
644
645sub tflushall () {
646    my $len;
647    for my $fh (keys %tarout) {
648        $len = 10240 - length($tarout{$fh});
649        $len += 10240 if $len < 1024;
650        $tarout{$fh} .= "\0" x $len;
651        flush($fh, \$tarout{$fh}, 10240);
652    }
653}
654
655END
656}
657
658exit;
659
660############################################################################
661
662sub tab () {
663    my $tabstring;
664
665    $tabstring = "\t" x ($indent_depth/2) . ' ' x ($indent_depth%2 * 4);
666    if (!$statdone) {
667        if ($_ =~ /^(?:name|print|prune|exec|ok|\(|\))/) {
668            $init{delayedstat} = 1;
669        } else {
670            my $statcall = '(($dev,$ino,$mode,$nlink,$uid,$gid) = '
671                         . $stat . '($_))';
672            if (exists $init{saw_or}) {
673                $tabstring .= "(\$nlink || $statcall) &&\n" . $tabstring;
674            } else {
675                $tabstring .= "$statcall &&\n" . $tabstring;
676            }
677            $statdone = 1;
678            $init{declarestat} = 1;
679        }
680    }
681    $tabstring =~ s/^\s+/ / if $out =~ /!$/;
682    $tabstring;
683}
684
685sub fileglob_to_re ($) {
686    my $x = shift;
687    $x =~ s#([./^\$()+])#\\$1#g;
688    $x =~ s#([?*])#.$1#g;
689    "^$x\\z";
690}
691
692sub n ($$) {
693    my ($pre, $n) = @_;
694    $n =~ s/^-/< / || $n =~ s/^\+/> / || $n =~ s/^/== /;
695    $n =~ s/ 0*(\d)/ $1/;
696    "($pre $n)";
697}
698
699sub quote ($) {
700    my $string = shift;
701    $string =~ s/\\/\\\\/g;
702    $string =~ s/'/\\'/g;
703    "'$string'";
704}
705
706__END__
707
708=head1 NAME
709
710find2perl - translate find command lines to Perl code
711
712=head1 SYNOPSIS
713
714        find2perl [paths] [predicates] | perl
715
716=head1 DESCRIPTION
717
718find2perl is a little translator to convert find command lines to
719equivalent Perl code.  The resulting code is typically faster than
720running find itself.
721
722"paths" are a set of paths where find2perl will start its searches and
723"predicates" are taken from the following list.
724
725=over 4
726
727=item C<! PREDICATE>
728
729Negate the sense of the following predicate.  The C<!> must be passed as
730a distinct argument, so it may need to be surrounded by whitespace and/or
731quoted from interpretation by the shell using a backslash (just as with
732using C<find(1)>).
733
734=item C<( PREDICATES )>
735
736Group the given PREDICATES.  The parentheses must be passed as distinct
737arguments, so they may need to be surrounded by whitespace and/or
738quoted from interpretation by the shell using a backslash (just as with
739using C<find(1)>).
740
741=item C<PREDICATE1 PREDICATE2>
742
743True if _both_ PREDICATE1 and PREDICATE2 are true; PREDICATE2 is not
744evaluated if PREDICATE1 is false.
745
746=item C<PREDICATE1 -o PREDICATE2>
747
748True if either one of PREDICATE1 or PREDICATE2 is true; PREDICATE2 is
749not evaluated if PREDICATE1 is true.
750
751=item C<-follow>
752
753Follow (dereference) symlinks.  The checking of file attributes depends
754on the position of the C<-follow> option. If it precedes the file
755check option, an C<stat> is done which means the file check applies to the
756file the symbolic link is pointing to. If C<-follow> option follows the
757file check option, this now applies to the symbolic link itself, i.e.
758an C<lstat> is done.
759
760=item C<-depth>
761
762Change directory traversal algorithm from breadth-first to depth-first.
763
764=item C<-prune>
765
766Do not descend into the directory currently matched.
767
768=item C<-xdev>
769
770Do not traverse mount points (prunes search at mount-point directories).
771
772=item C<-name GLOB>
773
774File name matches specified GLOB wildcard pattern.  GLOB may need to be
775quoted to avoid interpretation by the shell (just as with using
776C<find(1)>).
777
778=item C<-perm PERM>
779
780Low-order 9 bits of permission match octal value PERM.
781
782=item C<-perm -PERM>
783
784The bits specified in PERM are all set in file's permissions.
785
786=item C<-type X>
787
788The file's type matches perl's C<-X> operator.
789
790=item C<-fstype TYPE>
791
792Filesystem of current path is of type TYPE (only NFS/non-NFS distinction
793is implemented).
794
795=item C<-user USER>
796
797True if USER is owner of file.
798
799=item C<-group GROUP>
800
801True if file's group is GROUP.
802
803=item C<-nouser>
804
805True if file's owner is not in password database.
806
807=item C<-nogroup>
808
809True if file's group is not in group database.
810
811=item C<-inum INUM>
812
813True file's inode number is INUM.
814
815=item C<-links N>
816
817True if (hard) link count of file matches N (see below).
818
819=item C<-size N>
820
821True if file's size matches N (see below) N is normally counted in
822512-byte blocks, but a suffix of "c" specifies that size should be
823counted in characters (bytes) and a suffix of "k" specifes that
824size should be counted in 1024-byte blocks.
825
826=item C<-atime N>
827
828True if last-access time of file matches N (measured in days) (see
829below).
830
831=item C<-ctime N>
832
833True if last-changed time of file's inode matches N (measured in days,
834see below).
835
836=item C<-mtime N>
837
838True if last-modified time of file matches N (measured in days, see below).
839
840=item C<-newer FILE>
841
842True if last-modified time of file matches N.
843
844=item C<-print>
845
846Print out path of file (always true). If none of C<-exec>, C<-ls>,
847C<-print0>, or C<-ok> is specified, then C<-print> will be added
848implicitly.
849
850=item C<-print0>
851
852Like -print, but terminates with \0 instead of \n.
853
854=item C<-exec OPTIONS ;>
855
856exec() the arguments in OPTIONS in a subprocess; any occurrence of {} in
857OPTIONS will first be substituted with the path of the current
858file.  Note that the command "rm" has been special-cased to use perl's
859unlink() function instead (as an optimization).  The C<;> must be passed as
860a distinct argument, so it may need to be surrounded by whitespace and/or
861quoted from interpretation by the shell using a backslash (just as with
862using C<find(1)>).
863
864=item C<-ok OPTIONS ;>
865
866Like -exec, but first prompts user; if user's response does not begin
867with a y, skip the exec.  The C<;> must be passed as
868a distinct argument, so it may need to be surrounded by whitespace and/or
869quoted from interpretation by the shell using a backslash (just as with
870using C<find(1)>).
871
872=item C<-eval EXPR>
873
874Has the perl script eval() the EXPR. 
875
876=item C<-ls>
877
878Simulates C<-exec ls -dils {} ;>
879
880=item C<-tar FILE>
881
882Adds current output to tar-format FILE.
883
884=item C<-cpio FILE>
885
886Adds current output to old-style cpio-format FILE.
887
888=item C<-ncpio FILE>
889
890Adds current output to "new"-style cpio-format FILE.
891
892=back
893
894Predicates which take a numeric argument N can come in three forms:
895
896   * N is prefixed with a +: match values greater than N
897   * N is prefixed with a -: match values less than N
898   * N is not prefixed with either + or -: match only values equal to N
899
900=head1 SEE ALSO
901
902find
903
904=cut
905!NO!SUBS!
906
907close OUT or die "Can't close $file: $!";
908chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
909exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';
910chdir $origdir;
Note: See TracBrowser for help on using the repository browser.