File Coverage

blib/lib/File/Find/Node.pm

Criterion	Covered	Total	%
statement	201	215	93.4
branch	50	66	75.7
condition	27	33	81.8
subroutine	59	59	100.0
pod	37	37	100.0
total	374	410	91.2

package File::Find::Node;

use 5.006;
use strict;
use warnings;
use Carp;

our $VERSION = '0.03';

#
# constructor
#

use constant PATH     =>  0;
use constant NAME     =>  1;
use constant LEVEL    =>  2;
use constant PRUNE    =>  3;
use constant FOLLOW   =>  4;
use constant PARENT   =>  5;
use constant PROCESS  =>  6;
use constant POSTPROC =>  7;
use constant FILTER   =>  8;
use constant ERRPROC  =>  9;
use constant STAT     => 10;
use constant ARG      => 11;
use constant USER     => 12;
use constant GROUP    => 13;
use constant MAXFORK  => 14;

sub new {
    my ($class, $path) = @_;
    defined($path) or $path = ".";
    $path =~ s{/+}{/}g;
    $path =~ s{/$}{} if $path ne "/";
    my $self = [
        $path,  # PATH
        $path,  # NAME
        0,      # LEVEL
        0,      # PRUNE
        0,      # FOLLOW
        undef,  # PARENT
        undef,  # PROCESS
        undef,  # POSTPROC
        undef,  # FILTER
        undef,  # ERRPROC
        undef,  # STAT
        undef,  # ARG
        {},     # USER  cache for getpwuid()
        {},     # GROUP cache for getgrgid()
        0       # MAXFORK
    ];
    $self->[NAME] =~ s{.*/}{};
    bless($self);
}

#
# private object methods
#

# _error calls error callback function or calls carp().

sub _error {
    my ($self, $what) = @_;
    if ($self->[ERRPROC]) {
        $self->[ERRPROC]->($self, $what);
    }
    else {
        my $path = $self->[PATH];
        carp(__PACKAGE__, " - $what($path) - $!");
    }
}

# _cycle returns true if this directory is in the parent chain

sub _cycle {
    my $self = shift;
    my ($inum, $dev) = ($self->inum, $self->dev);
    for (my $p = $self->[PARENT]; $p; $p = $p->[PARENT]) {
        return 1 if $dev == $p->dev && $inum == $p->inum;
    }
    0;
}

#
# public object methods
#

sub process {
    my $self = shift;
    $self->[PROCESS] = shift;
    $self;
}

sub post_process {
    my $self = shift;
    $self->[POSTPROC] = shift;
    $self;
}

sub filter {
    my $self = shift;
    $self->[FILTER] = shift;
    $self;
}

sub error_process {
    my $self = shift;
    $self->[ERRPROC] = shift;
    $self;
}

sub arg {
    my $self = shift;
    $self->[ARG] or ($self->[ARG] = {});
}

sub prune {
    my $self = shift;
    $self->[PRUNE] = 1;
    $self;
}

sub stop {
    my $self = shift;
    for (my $p = $self; $p; $p = $p->[PARENT]) {
        $p->[PRUNE] = 1;
    }
    $self;
}

sub follow {
    my $self = shift;
    $self->[FOLLOW] = (@_ == 0 || shift);
    $self;
}

sub fork {
    my $self = shift;
    $self->[MAXFORK] = ($self->[LEVEL] > 0 && @_ > 0) ? shift : 0;
    $self;
}

sub path {
    shift->[PATH];
}

sub name {
    shift->[NAME];
}

sub parent {
    shift->[PARENT];
}

sub level {
    shift->[LEVEL];
}

# These methods return saved stat info

sub stat {
    @{shift->[STAT]};
}

sub dev {
    shift->[STAT]->[0];
}

sub inum {
    shift->[STAT]->[1];
}

sub ino {
    shift->[STAT]->[1];
}

sub mode {
    shift->[STAT]->[2];
}

sub perm {
    shift->[STAT]->[2] & 07777;
}

sub type {
    my $idx = (shift->[STAT]->[2] >> 12) & 017;
    ("?", "p", "c", "?", "d", "?", "b", "?",
     "f", "?", "l", "?", "s", "?", "?", "?")[$idx];
}

sub links {
    shift->[STAT]->[3];
}

sub nlink {
    shift->[STAT]->[3];
}

sub uid {
    shift->[STAT]->[4];
}

sub gid {
    shift->[STAT]->[5];
}

sub user {
    my $self = shift;
    my $uid = $self->uid;
    if (exists($self->[USER]->{$uid})) {
        return $self->[USER]->{$uid};
    }
    my $user = getpwuid($uid);
    $self->[USER]->{$uid} = defined($user) ? $user : $uid;
}

sub group {
    my $self = shift;
    my $gid = $self->gid;
    if (exists($self->[GROUP]->{$gid})) {
        return $self->[GROUP]->{$gid};
    }
    my $group = getgrgid($gid);
    $self->[GROUP]->{$gid} = defined($group) ? $group : $gid;
}

sub rdev {
    shift->[STAT]->[6];
}

sub size {
    shift->[STAT]->[7];
}

sub atime {
    shift->[STAT]->[8];
}

sub mtime {
    shift->[STAT]->[9];
}

sub ctime {
    shift->[STAT]->[10];
}

sub blksize {
    shift->[STAT]->[11];
}

sub blocks {
    shift->[STAT]->[12];
}

# empty returns true for an empty directory or a zero length regular file,
# otherwise false.

sub empty {
    my $self = shift;
    my $ftype = $self->type;
    if ($ftype eq "f") {
        return $self->size == 0;
    }
    elsif ($ftype eq "d") {
        my $dirh;
        if (!opendir($dirh, $self->[PATH])) {
            $self->_error("opendir");
            return 0;
        }
        my $ret = 1;
        while (my $name = readdir($dirh)) {
            if ($name ne "." && $name ne "..") {
                $ret = 0;
                last;
            }
        }
        closedir($dirh);
        return $ret;
    }
    0;
}

# refresh calls stat() or lstat() to load saved stat info

sub refresh {
    my $self = shift;
    my $path = $self->[PATH];
    my @stat;
    if ($self->[FOLLOW]) {
        @stat = CORE::stat($path) or @stat = CORE::lstat($path);
    }
    else {
        @stat = CORE::lstat($path);
    }
    if (@stat) {
        $self->[STAT] = \@stat;
    }
    else {
        $self->_error("stat");
    }
    $self;
}

# find performs the directory traversal

sub find {
    no warnings "recursion";
    my $self = shift;
    $self->refresh->[STAT] or return 0;  # loads stat info

    # avoid cycles

    my $ftype = $self->type;
    return 0 if $ftype eq "d" && $self->[FOLLOW] && $self->_cycle;

    # call process callback

    if ($self->[PROCESS]) {
        $self->[PROCESS]->($self);
    }

    # skip directory if pruned

    return 0 if $ftype ne "d" || $self->[PRUNE];

    # fork sub process if requested by $f->fork

    my $forked = 0;
    if ($self->[LEVEL] > 0 && $self->[MAXFORK] > 1) {
        my $pid = CORE::fork;
        if (!defined($pid)) {
            $self->_error("fork");
        }
        elsif ($pid == 0) {   # sub process continues
            $forked = 1;
        }
        else {
            return $self->[MAXFORK]  # parent process returns
        }
    }

    # read and filter the directory entries

    my $path = $self->[PATH];
    my $dirh;
    if (!opendir($dirh, $path)) {
        $self->_error("opendir");
        exit(0) if $forked;
        return 0;
    }
    my @dirent = $self->[FILTER] ?
        $self->[FILTER]->(readdir($dirh)) : readdir($dirh);
    closedir($dirh);

    # visit the directory entries

    my $maxfork = my $numfork = 0;
    foreach my $name (@dirent) {
        next if $name eq "." || $name eq "..";

        # build child object

        my $child;
        @$child = @$self;
        $child->[PATH] = $path ne "/" ? "$path/$name" : "/$name";
        $child->[NAME] = $name;
        $child->[PARENT] = $self;
        $child->[LEVEL]++;
        $child->[STAT] = undef;
        $child->[ARG]  = undef;
        $child->[MAXFORK] = 0;
        bless($child);

        # wait for sub processes to exit

        while ($numfork > 0 && $numfork >= $maxfork) {
            wait;
            $numfork--;
        }

        # visit the child with a recursive call

        my $forkinfo = $child->find;

        if ($forkinfo > 1) {     # a sub process was forked
            $numfork++;
            $maxfork = $forkinfo;
        }
        last if $self->[PRUNE];  # may have been pruned by child
    }

    # call post_process callback

    if (!$self->[PRUNE] && $self->[POSTPROC]) {
        $self->[POSTPROC]->($self);
    }

    # wait for any remaining sub processes

    while ($numfork-- > 0) {
        wait;
    }
    exit(0) if $forked;
    return 0;
}
1;

__END__