view release on metacpan or  search on metacpan

script/find2perl  view on Meta::CPAN

# Set the variable \$File::Find::dont_use_nlink if you're using AFS,
# since AFS cheats.

# for the convenience of &wanted calls, including -eval statements:
use vars qw/*name *dir *prune/;
*name   = *File::Find::name;
*dir    = *File::Find::dir;
*prune  = *File::Find::prune;

$declaresubs

END

if (exists $init{doexec}) {
    print <<'END';
use Cwd ();
my $cwd = Cwd::cwd();

END
}  

if (exists $init{ls}) {
    print <<'END';
my @rwx = qw(--- --x -w- -wx r-- r-x rw- rwx);
my @moname = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);

END
}

if (exists $init{user} || exists $init{ls} || exists $init{tar}) {
    print "my (%uid, %user);\n";
    print "while (my (\$name, \$pw, \$uid) = getpwent) {\n";
    print '    $uid{$name} = $uid{$uid} = $uid;', "\n"
        if exists $init{user};
    print '    $user{$uid} = $name unless exists $user{$uid};', "\n"
        if exists $init{ls} || exists $init{tar};
    print "}\n\n";
}

if (exists $init{group} || exists $init{ls} || exists $init{tar}) {
    print "my (%gid, %group);\n";
    print "while (my (\$name, \$pw, \$gid) = getgrent) {\n";
    print '    $gid{$name} = $gid{$gid} = $gid;', "\n"
        if exists $init{group};
    print '    $group{$gid} = $name unless exists $group{$gid};', "\n"
        if exists $init{ls} || exists $init{tar};
    print "}\n\n";
}

print $initnewer, "\n" if $initnewer ne '';
print $initfile, "\n" if $initfile ne '';
$flushall .= "exit;\n";
if (exists $init{declarestat}) {
    $out = <<'END' . $out;
    my ($dev,$ino,$mode,$nlink,$uid,$gid);

END
}

if ( $follow_in_effect ) {
$out =~ s/lstat\(\$_\)/lstat(_)/;
print <<"END";
$decl
# Traverse desired filesystems
File::Find::$find( {wanted => \\&wanted, follow => 1}, $roots);
$flushall

sub wanted {
$out;
}

END
} else {
print <<"END";
$decl
# Traverse desired filesystems
File::Find::$find({wanted => \\&wanted}, $roots);
$flushall

sub wanted {
$out;
}

END
}

if (exists $init{doexec}) {
    print <<'END';

sub doexec ($@) {
    my $ok = shift;
    my @command = @_; # copy so we don't try to s/// aliases to constants
    for my $word (@command)
        { $word =~ s#{}#$name#g }
    if ($ok) {
        my $old = select(STDOUT);
        $| = 1;
        print "@command";
        select($old);
        return 0 unless <STDIN> =~ /^y/;
    }
    chdir $cwd; #sigh
    system @command;
    chdir $File::Find::dir;
    return !$?;
}

END
}

if (exists $init{ls}) {
    print <<'INTRO', <<"SUB", <<'END';

sub sizemm {
    my $rdev = shift;
    sprintf("%3d, %3d", ($rdev >> 8) & 0xff, $rdev & 0xff);
}

sub ls () {
    my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
INTRO
        \$atime,\$mtime,\$ctime,\$blksize,\$blocks) = $stat(_);
SUB
    my $pname = $name;

    $blocks
        or $blocks = int(($size + 1023) / 1024);

    my $perms = $rwx[$mode & 7];
    $mode >>= 3;
    $perms = $rwx[$mode & 7] . $perms;
    $mode >>= 3;
    $perms = $rwx[$mode & 7] . $perms;
    substr($perms, 2, 1) =~ tr/-x/Ss/ if -u _;
    substr($perms, 5, 1) =~ tr/-x/Ss/ if -g _;
    substr($perms, 8, 1) =~ tr/-x/Tt/ if -k _;
    if    (-f _) { $perms = '-' . $perms; }
    elsif (-d _) { $perms = 'd' . $perms; }
    elsif (-l _) { $perms = 'l' . $perms; $pname .= ' -> ' . readlink($_); }
    elsif (-c _) { $perms = 'c' . $perms; $size = sizemm($rdev); }
    elsif (-b _) { $perms = 'b' . $perms; $size = sizemm($rdev); }
    elsif (-p _) { $perms = 'p' . $perms; }
    elsif (-S _) { $perms = 's' . $perms; }
    else         { $perms = '?' . $perms; }

    my $user = $user{$uid} || $uid;
    my $group = $group{$gid} || $gid;

    my ($sec,$min,$hour,$mday,$mon,$timeyear) = localtime($mtime);
    if (-M _ > 365.25 / 2) {
        $timeyear += 1900;
    } else {
        $timeyear = sprintf("%02d:%02d", $hour, $min);
    }

    printf "%5lu %4ld %-10s %3d %-8s %-8s %8s %s %2d %5s %s\n",
            $ino,
                 $blocks,
                      $perms,
                            $nlink,
                                $user,
                                     $group,
                                          $size,
                                              $moname[$mon],
                                                 $mday,
                                                     $timeyear,
                                                         $pname;
    1;
}

END
}


if (exists $init{cpio} || exists $init{tar}) {
print <<'END';

my %blocks = ();

sub flush {
    my ($fh, $varref, $blksz) = @_;

    while (length($$varref) >= $blksz) {
        no strict qw/refs/;
        syswrite($fh, $$varref, $blksz);
        substr($$varref, 0, $blksz) = '';
        ++$blocks{$fh};
    }
}

END
}


if (exists $init{cpio}) {
    print <<'INTRO', <<"SUB", <<'END';

my %cpout = ();
my %nc = ();

sub cpio {
    my ($fh, $fname, $nc) = @_;
    my $text = '';
    my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
        $atime,$mtime,$ctime,$blksize,$blocks);
    local (*IN);

    if ( ! defined $fname ) {
        $fname = 'TRAILER!!!';
        ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
          $atime,$mtime,$ctime,$blksize,$blocks) = (0) x 13;
    } else {
        ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
INTRO
          \$atime,\$mtime,\$ctime,\$blksize,\$blocks) = $stat(_);
SUB
        if (-f _) {
            open(IN, "./$_\0") || do {
                warn "Couldn't open $fname: $!\n";
                return;
            }
        } else {
            $text = readlink($_);
            $size = 0 unless defined $text;
        }
    }

    $fname =~ s#^\./##;
    $nc{$fh} = $nc;
    if ($nc eq 'n') {
        $cpout{$fh} .=
          sprintf("%06o%06o%06o%06o%06o%06o%06o%06o%011lo%06o%011lo%s\0",
            070707,
            $dev & 0777777,
            $ino & 0777777,
            $mode & 0777777,
            $uid & 0777777,
            $gid & 0777777,
            $nlink & 0777777,
            $rdev & 0177777,
            $mtime,
            length($fname)+1,
            $size,
            $fname);
    } else {
        $cpout{$fh} .= "\0" if length($cpout{$fh}) & 1;
        $cpout{$fh} .= pack("SSSSSSSSLSLa*",
            070707, $dev, $ino, $mode, $uid, $gid, $nlink, $rdev, $mtime,
            length($fname)+1, $size,
            $fname . (length($fname) & 1 ? "\0" : "\0\0"));
    }

    if ($text ne '') {
        $cpout{$fh} .= $text;
    } elsif ($size) {
        my $l;
        flush($fh, \$cpout{$fh}, 5120)
            while ($l = length($cpout{$fh})) >= 5120;
        while (sysread(IN, $cpout{$fh}, 5120 - $l, $l)) {
            flush($fh, \$cpout{$fh}, 5120);
            $l = length($cpout{$fh});
        }
        close IN;
    }
}

sub cflushall () {
    for my $fh (keys %cpout) {
        cpio($fh, undef, $nc{$fh});
        $cpout{$fh} .= "0" x (5120 - length($cpout{$fh}));
        flush($fh, \$cpout{$fh}, 5120);
        print $blocks{$fh} * 10, " blocks\n";
    }
}

END
}

if (exists $init{tar}) {
    print <<'INTRO', <<"SUB", <<'END';

my %tarout = ();
my %linkseen = ();

sub tar {
    my ($fh, $fname) = @_;
    my $prefix = '';
    my $typeflag = '0';
    my $linkname;
    my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
INTRO
        \$atime,\$mtime,\$ctime,\$blksize,\$blocks) = $stat(_);
SUB
    local (*IN);

    if ($nlink > 1) {
        if ($linkname = $linkseen{$fh, $dev, $ino}) {
            if (length($linkname) > 100) {
                warn "$0: omitting file with linkname ",
                     "too long for tar output: $linkname\n";
                return;
            }
            $typeflag = '1';
            $size = 0;
        } else {
            $linkseen{$fh, $dev, $ino} = $fname;
        }
    }
    if ($typeflag eq '0') {
        if (-f _) {
            open(IN, "./$_\0") || do {
                warn "Couldn't open $fname: $!\n";
                return;
            }
        } else {
            $linkname = readlink($_);
            if (defined $linkname) { $typeflag = '2' }
            elsif (-c _) { $typeflag = '3' }
            elsif (-b _) { $typeflag = '4' }
            elsif (-d _) { $typeflag = '5' }
            elsif (-p _) { $typeflag = '6' }
        }
    }

    if (length($fname) > 100) {
        ($prefix, $fname) = ($fname =~ m#\A(.*?)/(.{,100})\Z(?!\n)#);
        if (!defined($fname) || length($prefix) > 155) {
            warn "$0: omitting file with name too long for tar output: ",
                 $fname, "\n";
            return;
        }
    }

    $size = 0 if $typeflag ne '0';
    my $header = pack("a100a8a8a8a12a12a8a1a100a6a2a32a32a8a8a155",
                        $fname,
                        sprintf("%7o ", $mode &    0777),
                        sprintf("%7o ", $uid  & 0777777),
                        sprintf("%7o ", $gid  & 0777777),
                        sprintf("%11o ", $size),
                        sprintf("%11o ", $mtime),
                        ' 'x8,
                        $typeflag,
                        defined $linkname ? $linkname : '',
                        "ustar\0",
                        "00",
                        $user{$uid},
                        $group{$gid},
                        ($rdev >> 8) & 0xff,
                        $rdev & 0xff,
                        $prefix,
                     );