File Coverage

lib/Badger/Filesystem/Virtual.pm

Criterion	Covered	Total	%
statement	72	78	92.3
branch	27	38	71.0
condition	12	22	54.5
subroutine	7	8	87.5
pod	6	6	100.0
total	124	152	81.5

#========================================================================
#
# Badger::Filesystem::Virtual
#
# DESCRIPTION
#   Subclass of Badger::Filesystem which implements a virtual filesystem
#   composed from several source directories, conceptually layered on
#   top of each other.
#
# AUTHOR
#   Andy Wardley
#
#========================================================================

package Badger::Filesystem::Virtual;

use Badger::Debug ':dump';
use Badger::Class
    version   => 0.01,
    debug     => 0,
    base      => 'Badger::Filesystem',
#   accessors => 'root',                    # interferes
    utils     => 'blessed',
    constants => 'ARRAY CODE',
    constant  => {
        VFS          => __PACKAGE__,
        virtual      => __PACKAGE__,
        PATH_METHOD  => 'path',
        PATHS_METHOD => 'paths',
        ROOTS_METHOD => 'roots',
    },
    exports   => {
        any   => 'VFS',
    },
    messages => {
        bad_root  => 'Invalid root directory: %s',
        max_roots => 'The number of virtual filesystem roots exceeds the max_roots limit of %s',
    };

*definitive = \&definitive_write;

our $MAX_ROOTS = 32 unless defined $MAX_ROOTS;

sub init {
    my ($self, $config) = @_;

    # let the base class have a go first, so it can set rootdir et al
    $self->SUPER::init($config);

    # root can be a single item or list ref
    my $root = $config->{ root } || $self->{ rootdir };
    $root = [$root] unless ref $root eq ARRAY;
    $self->{ root } = $root;

    # the dynamic flag indicates that the list of roots can change so we must
    # recompute them each time we use them.  max_roots sets a limit on the
    # expansion to prevent runaways
    $self->{ dynamic   } = $config->{ dynamic };
    $self->{ max_roots } =
        defined $config->{ max_roots }
              ? $config->{ max_roots }
              : $MAX_ROOTS;

    # we must set cwd to / so that the relative -> absolute path translation
    # works as expected.  The concept of having a current working directory
    # in a VFS is just a bit too weird to contemplate anyway.
    $self->{ cwd } = $self->{ rootdir };

    $self->debug("Virtual root: ", join(', ', @$root), "\n" ) if $DEBUG;

    return $self;
}

sub roots {
    my $self = shift;

    if (my $roots = $self->{ roots }) {
        return wantarray
            ? @$roots
            :  $roots;
    }

    my $max    = $self->{ max_roots };
    my @paths  = @{ $self->{ root } };
    my (@roots, $type, $paths, $dir, $code);

    # If a positive max_roots is defined then we'll limit the number of
    # roots we resolve.  If it's zero or negative then it will pre-decrement
    # before being tested so will always be true
    while (@paths && --$max) {
        $dir = shift @paths || next;

        $type = ref $dir || do {
            # non-reference paths get added as they are
            $self->debug("discovered root directory: $dir\n") if DEBUG;
            push(@roots, $dir);
            next;
        };

        # anything else can expand out to one or more paths, each of which
        # can expand recursively, so we push all new paths back onto the
        # candidate list and test each in turn.

        if ($type eq CODE) {
            # call code ref
            $paths = $dir->();
            $self->debug(
                "discovered root directories from code ref: ",
                $self->dump_data_inline($paths), "\n"
            ) if DEBUG;
            unshift(@paths, ref $paths eq ARRAY ? @$paths : $paths);
            next;
        }
        elsif ($type eq ARRAY) {
            # expand list ref
            $self->debug(
                "discovered root directories from code ref: ",
                join(', ', @$dir), "\n"
            ) if DEBUG;
            unshift(@paths, @$dir);
            next;
        }
        elsif (blessed $dir) {
            # see if object has a path(), paths() or roots() method
            # TODO: this is broken - we don't want to recompute paths
            # each time just because we're using an object that has a
            # path
            if ($code = $dir->can(PATH_METHOD)
                     || $dir->can(PATHS_METHOD)
                     || $dir->can(ROOTS_METHOD) ) {
                $paths = $code->($dir);
                $self->debug(
                    "discovered root directories from $type object: $paths / ",
                    $self->dump_data_inline($paths), "\n"
                ) if DEBUG;
                unshift(@paths, ref $paths eq ARRAY ? @$paths : $paths);
                next;
            }
        }

        $self->error( bad_root => $dir );
    }

    # anything left in @paths means we must have blown the max_roots limit
    return $self->error_msg( max_roots => $self->{ max_roots } )
        if @paths;

    # we can cache roots if all are static and the dynamic flag isn't set
    $self->{ roots } = \@roots
        unless $self->{ dynamic };

    $self->debug("resolved roots: [\n  ", join("\n  ", @roots), "\n]\n") if DEBUG;

    return wantarray
        ?  @roots
        : \@roots;
}

sub definitive_paths {
    my $self  = shift;
    my $path  = $self->absolute(@_);
    my @paths = map { $self->merge_paths($_, $path) } $self->roots;
    return wantarray
        ?  @paths
        : \@paths;
}

sub definitive_write {
    my $self = shift;
    $self->debug("definitive_write(", join(', ', @_), ")\n") if DEBUG;
    my $path = $self->absolute(@_);
    return $self->join_directory($self->roots->[0], $path);
}

sub definitive_read {
    my $self = shift;
    my $path = $self->absolute(@_);
    my ($base, $full);

    $self->debug("definitive_read($path)") if DEBUG;

    foreach $base ($self->roots) {
        $full = $self->merge_paths($base, $path);
        $self->debug("looking for [$base] + [$path] => $full\n") if DEBUG;
        return $full if -e $full;
        $self->debug("not found\n") if DEBUG;
    }
    return undef;
}

sub read_directory {
    my $self = shift;
    my $path = $self->absolute(shift);
    my $all  = shift;
    my ($base, $full, $dirh, $item, @items, %seen);

    require IO::Dir;

    foreach $base ($self->roots) {
        $full = $self->join_directory($base, $path);
        $self->debug("Opening directory: $full\n") if DEBUG;
        $dirh = IO::Dir->new($full)
            || next;
# Some directory may not exist, so ignore them
#           || $self->error_msg( open_failed => directory => $full => $! );
        while (defined ($item = $dirh->read)) {
            if (DEBUG) {
                if ($seen{ $item }) {
                    $self->debug("skipping $item (already seen)");
                }
                else {
                    $self->debug("adding $item");
                }
            }
            push(@items, $item) unless $seen{ $item }++;
        }
        $dirh->close;
    }
    @items = $self->FILESPEC->no_upwards(@items)
        unless $all || ref $self && $self->{ all_entries };

    return wantarray ? @items : \@items;
}


1;

__END__