view release on metacpan or  search on metacpan

lib/Badger/Filesystem/Path.pm  view on Meta::CPAN

    my $self = shift;
    my $this = quotemeta $self->collapse->path;
    my $that = shift || return $self->error_msg( bad_look => 'above' );
    $that = $self->new("$that") unless blessed $that && $that->isa(__PACKAGE__);
    $that = $that->collapse->path;
    $self->debug("does $that match /^$this/ ??\n") if $DEBUG;
    $that =~ /^$this/;
}

sub below {
    my $self = shift;
    my $that = shift || return $self->error_msg( bad_look => 'above' );
    $that = $self->new("$that") unless blessed $that && $that->isa(__PACKAGE__);
    $that->above($self);
}

sub base {
    my $self = shift;
    return $self->{ directory } || $self->{ path };
}

sub parent {
    my $self   = shift;
    my $skip   = shift || 0;
    my $parent = $self->{ parent }
             ||= $self->filesystem->directory(
                 $self->{ directory } ||= $self->path_up
             );

    return
        # don't return parents above the root
        $self->{ path } eq $parent->{ path } ? $self
        # delegate to parent if there are generations to skip
      : $skip ? $parent->parent($skip - 1)
        # otherwise we've found the parent we're looking for
      : $parent;
}

sub path_up {
    my $self = shift;
    my $fs   = $self->filesystem;
    my $path = $fs->split_directory($self->{ path });

    $self->debug("split path [$path] into [", join(', ', @$path), "]\n")
        if $DEBUG;

    if (@$path > 1) {
        # multiple items in path can be relative or absolute - we're not
        # fussed.  e.g. /foo/bar ==> /foo  or  foo/bar ==> foo
        pop(@$path);
    }
    elsif (@$path == 1) {
        # if there's a single item in a path then it's either a single
        # relative path item (e.g. 'foo' ==> ['foo']), in which case we
        # return the current working directory, or it's an empty item
        # indicating the root directory (e.g. '/' => ['']) in which case we
        # do nothing, because you can't go up from the root directory.
        if (length $path->[0]) {
            return $fs->cwd;
        }
        $self->not_implemented("going up from relative paths");
    }
    else {
        $self->error("Invalid path (no elements)\n");
    }

    return $fs->join_directory($path);
}

sub exists {
    shift->stat;
}

sub must_exist {
    my $self = shift;

    unless ($self->exists) {
        if (@_ && $_[0]) {
            my $flag = shift;
            # true flag indicates we should attempt to create it
            $self->create(@_);      # pass any other args, like dir file permission
        }
        else {
            return $self->error_msg( no_exist => $self->type, $self->{ path } );
        }
    }
    return $self;
}

sub create {
    shift->not_implemented;
}

sub stat {
    my $self  = shift->must_exist;
    my $stats = $self->filesystem->stat_path($self->{ path })
            ||  return $self->decline_msg( not_found => file => $self->{ path } );

    # the definitive path can be tagged on the end
#    $self->{ definitive } = $stats->[STAT_PATH]
#        if defined $stats->[STAT_PATH];

    return wantarray
        ? @$stats
        :  $stats;
}

sub stats {
    my $stats = $_[0]->{ stats } ||= $_[0]->stat;
    return wantarray
        ? @$stats
        :  $stats;
}

sub restat {
    my $self = shift;
    delete $self->{ stats };
    delete @$self{ keys %$TS_FIELD }; # timestamps for created, modified, etc.
    return $self->stats;
}

sub permissions {
    shift->mode & 0777;
}

sub chmod {
    my $self = shift;
    $self->filesystem->chmod_path($self->{ path }, @_);
    return $self;
}

sub basename {
    my $self = shift;
    my $name = $self->name;
    $name = $self->{ path } unless defined $name;
    $name =~ s/$MATCH_EXT//g;
    return $name;
}

sub extension {
    my $self = shift;
    return $self->{ path } =~ $MATCH_EXT
        ? $1
        : '';
}

sub filesystem {
    my $self = shift;
    return $self->class->any_var('FILESYSTEM')->prototype
        unless ref $self;
    $self->{ filesystem }
        ||= $self->class->any_var('FILESYSTEM')->prototype;
}

sub visit {
    my $self    = shift;
    my $visitor = $self->filesystem->visitor(@_);