view release on metacpan or  search on metacpan

lib/Tree/File.pm  view on Meta::CPAN

    my $data = $self->load_file($file);
    $lock_mgr->unlock();
    return $self->_new_node($root, $data, \%$arg);
  }

  elsif (-d $file) {
    my $dir;
    opendir $dir, $file or croak "can't open branch directory $dir: $!";

    my $tree = {};
    for my $twig (grep { $_ !~ /\A\./ && ! -l "$file/$_" && $_ ne 'CVS' } readdir $dir) {
      $tree->{$twig} = $preload
                       ? $self->_load("$root/$twig", $preload-1, { %$arg, preload => $preload-1})
                       : sub { $self->_load("$root/$twig", 0, { %$arg, preload => 0 }) };
    }
    $lock_mgr->unlock();
    return $self->_new_node($root, $tree, { %$arg, type => 'dir' });
  }

  else {
    $lock_mgr->unlock();
    croak "$file doesn't exist or isn't a normal file or directory";
  }
}

=head2 C<< $tree->get($id) >>

This returns the branch with the given name.  If the name contains slashes,
they indicate recursive fetches, so that these two calls are identical:

  $tree->get("foo")->get("bar")->get("baz");

  $tree->get("foo/bar/baz");

Leading slashes are ignored.

If a second, true argument is passed to C<get>, any missing data structures
will be autovivified as needed to get to the leaf.

=cut

sub _not_found {
  my ($self) = shift;
  if ($self->{not_found}) { return $self->{not_found}->(@_) }
  return;
}

sub _found {
  my ($self) = shift;
  return $self->{found} ? $self->{found}->($self, @_) : $_[1];
}

sub get {
  my ($self, $id, $autovivify) = @_;

  $id && $id =~ s|\A/+||;
  my $rest;

  croak "get called on $self without property identifier" unless defined $id;

  ($id, $rest) = split m|/|, $id, 2;
  if ($rest) {
    my $head = $self->get($id, $autovivify);
    return $self->_not_found($id, $self->{root}) unless $head;
    return $head->get($rest, $autovivify);
  }

  if (exists $self->{data}{$id}) {
    if (ref $self->{data}{$id} eq 'CODE') {
      $self->{data}{$id} = $self->{data}{$id}->();
    }
    return $self->_found($id, $self->{data}{$id});
  }

  if ($autovivify) {
    return $self->{data}{$id} =
      $self->_new_node("$self->{root}/$id", {});
  }

  return $self->_not_found($id, $self->{root});
}

=head2 C<< $tree->set($id, $value) >>

This sets the identified branch's value to the given value.  Hash references
are automatically expanded into trees.

=cut

sub set { ## no critic Ambiguous
  my ($self, $id, $value, $root) = @_;

  $value = $value->data if eval { $value->isa("Tree::File") };

  croak "set called on readonly tree" if $self->{readonly};

  $id && $id =~ s|\A/+||;
  $root = $id unless $root;
  my $rest;

  croak "set called on $self without property identifier" unless defined $id;

  ($id, $rest) = split m|/|, $id, 2;
  if ($rest) { return $self->get($id, 1)->set($rest, $value, $root); }

  return $self->{data}{$id} =
    $self->_new_node($root, $value);
}

=head2 C<< $tree->delete($id) >>

This method deletes the identified branch (and returns the deleted value).

=cut

sub delete { ## no critic Homonym
  my ($self, $id) = @_;

  croak "delete called on readonly tree" if $self->{readonly};

  $id && $id =~ s|\A/+||;
  my $rest;

  croak "delete called on $self without property identifier" unless defined $id;

  ($id, $rest) = split m|/|, $id, 2;
  if ($rest) { return $self->get($id)->delete($rest); }

  return delete $self->{data}{$id};
}

=head2 C<< $tree->move($old_id, $new_id) >>

This method deletes the value at the old id and places it at the new id.

=cut

sub move {
  my ($self, $old_id, $new_id) = @_;

  $self->set($new_id, $self->delete($old_id));
}

=head2 C<< $tree->path() >>

This method returns the path to this node from the root.

=cut

sub path {
  my ($self) = @_;
  return $self->{root};
}

=head2 C<< $tree->basename() >>

This method retuns the base name of the node.  (If, for example, the path to
the node is "/things/good/all" then its base name is "all".)

=cut

sub basename {
  my ($self) = @_;
  my @parts = split m{/}, $self->path();
  return $parts[-1];
}

sub _handoff {
  my $self = shift;
  my $method = (caller(1))[3];
  $method =~ s/.*:://;
  my $node = $self->get(@_);
  unless ($node) {
    return $self->_not_found(@_);
  }
  #warn "handing off $method to " . $node->path . "\n";
  $node->$method;
}

=head2 C<< $tree->node_names() >>

This method returns the names of all the nodes beneath this branch.

=cut

sub node_names {
  my $self = shift;
  return $self->_handoff(@_) if @_;
  return sort keys %{$self->{data}};
}

=head2 C<< $tree->nodes() >>

This method returns each node beneath this branch.

=cut

sub nodes {
  my $self = shift;
  return $self->_handoff(@_) if @_;
  return map { $self->get($_) } $self->node_names();
}

=head2 C<< $tree->branch_names >>

=cut

sub branch_names {
  my $self = shift;
  return $self->_handoff(@_) if @_;
  return grep { eval { $self->get($_)->isa("Tree::File") } } $self->node_names;
}

=head2 C<< $tree->branches >>

This method returns all the nodes on this branch which are also branches (that
is, are also Tree::File objects).

=cut

sub branches {
  my $self = shift;
  return $self->_handoff(@_) if @_;
  return map { $self->get($_) } $self->branch_names();