# -*-perl-*-

# $Id: Node.plm,v 1.9 2007/01/04 19:17:52 thomas Exp $

# Handle the what node objects.

=head1 NAME

What::Node - Ancestor of all @@BASENMAE@@ node types

=head1 SEE ALSO

What::Node::I<type>

=cut

package What::Node;

use strict;
use FileHandle;
use DirHandle;
use Data::Dumper;

use base qw(What);

# This counts inodes loaded into the system, from 0 to infinity.
our $inodectr = 0;

our %opts = ();

###############################################################################
# Methods defined here:
#
# new ($invocant)
# $self->setattrs ($section, $(%)attrs [,$path [,$create]])
# $self->getattrs ($section, %attrs)  (path, attr)
# $self->inode (void)
# $self->getchildren ($section, %attrs) (path, child)
# $self->addchildren (%kids)
# $self->getoptions ([$option])
# $self->setoptions ($(%)opts)
# $self->get_default_options (void)
# $self->get_current_options (void)
# $self->un_link ($section, $path [,@keys])
# $self->mv ($section, $from, $to)
# $self->hardlink ($section, $to, $source)
# . . .
# $class->write ($what, $sname, $cname, $fh)
###############################################################################


###############################################################################
# Create a new node.

sub new {
  my $invocant = shift;

  my $class = ref ($invocant) || $invocant;
  $invocant->requireclass ($class);

  my $self = bless {i => $inodectr++} => $class;
  ref ($invocant) && exists ($invocant->{o}) and $self->{o} = $invocant->{o};
  return $self;
}


###############################################################################

sub setattrs {
  my $self = shift;
  my $section = shift;
  my $attrs = shift;
  my $path = shift;
  my $create = shift;

  defined ($path) and $self = $self->find_node ($section, $path, $create);
  defined ($self) or return 0;

  foreach (keys %$attrs) {
    $_ eq 'path' and next;
    (defined $attrs->{$_})
      and $self->{a}->{$_} = $section->substitute_vars ($attrs->{$_});
  }
  return $self;
}

sub clearattrs {
  my $self = shift;
  my $section = shift;
  my $attrs = shift;
  my $path = shift;
  my $create = shift;

  defined ($path) and $self = $self->find_node ($section, $path, $create);
  defined ($self) or return 0;

  $self->{a} = {};
  return $self;
}


###############################################################################
# Return attribute values.  The input hash can have two keys:
#  'path' means find a subdirectory of $self.
#  'attr' means return a single attribute.
#
#  If 'attr' is specified, the return will be a scalar, or undef.
#  Otherwise, the return will be a (maybe empty) hashref, or undef.

sub getattrs {
  my $self = shift;
  my $section = shift;
  my %attrs = (@_);

  defined ($attrs{path})
    and $self = $self->find_node ($section, $attrs{path}, 0);
  defined ($self) or return undef;

  exists ($self->{a}) or $self->{a} = {};
  defined ($attrs{attr}) or return $self->{a};
  exists ($self->{a}->{$attrs{attr}}) and return $self->{a}->{$attrs{attr}};
  return undef;
}


###############################################################################

# Set the text component of a node.  Perform variable substitution
# if $dosubs is set.
sub settext {
  my $self = shift;
  my $section = shift;
  my $text = shift;
  my $path = shift;

  defined ($path) and $self = $self->find_node ($section, $path, 0);
  defined ($self) or return 0;

  $self->{t} = $section->substitute_vars ($text);
  return $self;
}


# Fetch the text component back out
sub gettext {
  my $self = shift;
  my $section = shift;
  my $path = shift;

  $self = $self->find_node ($section, $path, 0) if defined ($path);
  return undef unless defined ($self);

  return $self->{t} if exists $self->{t};
  undef;
}


###############################################################################
# Return the inode of the node

sub inode { $_[0]->{i} }


###############################################################################
# Return children of a node.  The input hash can have two keys:
#  'path' means find a subdirectory of $self.
#  'child' means return a single child node.
#
#  If 'child' is specified, the return will be a node, or undef.
#  Otherwise, the return will be a (maybe empty) hashref, or undef.

sub getchildren {
  my $self = shift;
  my $section = shift;
  my %attrs = @_;

  defined ($attrs{path})
    and $self = $self->find_node ($section, $attrs{path}, 0);
  defined ($self) or return undef;

  exists ($self->{k}) or $self->{k} = {};
  defined ($attrs{child}) or return $self->{k};
  exists ($self->{k}->{$attrs{child}}) and return $self->{k}->{$attrs{child}};
  return undef;
}


###############################################################################
# Add the child(ren) to the passed node.
sub addchildren {
  my $self = shift;
  my $children = { @_ };

  exists ($self->{k}) or $self->{k} = {};
  foreach (keys %$children) {
    $self->{k}->{$_} = $children->{$_};
  }
  return 1;
}


###############################################################################
# Get/set options for the node.

sub getoptions {
  my $self = shift;
  my $option = shift;

  if (defined $option) {
    exists ($self->{o}) or return undef;
    exists ($self->{o}->{$option}) or return undef;
    return $self->{o}->{$option};
  }

  exists ($self->{o}) or return {};
  return $self->{o};
}

sub setoptions {
  my $self = shift;
  my $opts = shift;

  foreach (keys %$opts) {
    defined ($opts->{$_}) and $self->{o}->{$_} = $opts->{$_};
  }
}

sub get_default_options {
  my $self = shift;
  no strict 'refs';
  my $class = ref($self);
  my $opts = {%{"${class}::opts"}};
  use strict;
  return $opts;
}

sub get_current_options {
  my $self = shift;

  my $opts = {};

  $opts = $self->get_default_options;

  # Get the last word of the type
  my ($type) = (ref($self) =~ /([^:]+)$/);
  foreach (keys %::opts) {
    /^$type\:(.*)$/i or next;
    $opts->{$1} = $::opts{$_};
  }
  return $opts;
}

###############################################################################
# Delete nodes or node attributes.  In order to delete a node, the 'path'
# parameter must be specified (thus it is impossible to delete the root node).
# If other attribute keys are listed, only those attributes will be deleted
# (not the node).

sub un_link {
  my $self = shift;
  my $section = shift;
  my $path = shift;
  my (@keys) = (@_);

  if (@keys) {
    # Only delete certain attributes
    (defined $path) and $self = $self->find_node ($section, $path, 0);
    defined ($path) or return 0;
    defined ($self->{a}) or $self->{a} = {};
    foreach (@keys) {
      delete $self->{a}->{$_};
    }
    return 1;
  }

  # Delete a subtree
  defined ($path) or return 0;
  my ($parent, $child) = $self->find_parent ($section, $path, 0);
  return (0) unless (defined ($child) && defined ($parent));
  exists ($parent->{k}) or $parent->{k} = {};
  delete $parent->{k}->{$child};
  return 1;
}



###############################################################################
# Move part of the tree from one place to another.  Forbid cross-section moves.

sub mv {
  my $self = shift;
  my $section = shift;
  my $from = shift;
  my $to = shift;
  my $merge = shift;

  defined ($from) && defined ($to) or return 0;

  my ($from_parent, $from_last) = $self->find_parent ($section, $from, 0);
  defined ($from_parent) or return 0;
  my $from_node = $from_parent->{k}->{$from_last};
  defined ($from_node) or return 0;

  # Have to delete $from_parent->{k}->{$from_last} before find_parent ($to),
  # in case the mv looks like mv (from) foo (to) foo/bar/qux
  delete $from_parent->{k}->{$from_last};
  my ($to_node, $to_last) = $self->find_parent ($section, $to, 1);
  defined ($to_node) or return 0;

  # Don't allow cross-class moves
  if (ref ($from_node) ne ref($to_node)) {
    $from_parent->{k}->{$from_last} = $from_node;
    return 0;
  }

  if (!$merge || !exists ($to_node->{k}->{$to_last})) {
    # Simple substitution
    $to_node->{k}->{$to_last} = $from_node;

  } else {
    # Otherwise do the merge
    $self->mv_merge_r ($section, $from_node, $to_node->{k}->{$to_last});
  }

}

sub mv_merge_r {
  my $self = shift;
  my $section = shift;
  my $from_node = shift;
  my $to_node = shift;

  # Merge attributes
  if (exists $from_node->{a}) {
    foreach (keys %{$from_node->{a}}) {
      $to_node->{a}->{$_} = $from_node->{a}->{$_};
    }
  }

  # Merge kids - maybe recurse
  if (exists $from_node->{k}) {
    foreach (keys %{$from_node->{k}}) {
      if (exists $to_node->{k}->{$_}) {
	$self->mv_merge_r ($section,
			   $from_node->{k}->{$_},
			   $to_node->{k}->{$_});
      } else {
	$to_node->{k}->{$_} = $from_node->{k}->{$_};
      }
    }
  }
  return 1;
}

###############################################################################
# Create a hard link.  Forbid cross-class links.

sub hardlink {
  my $self = shift;
  my $section = shift;
  my $path = shift;
  my $source = shift;

  my $node = $self->find_node ($section, $source, 0);
  if (!defined $node) {
    $self->err (ref($self) . ":hardlink: Can't find source node $source!\n");
    return 0;
  }

  # Create destination nodes as needed.  This is guaranteed to succeed.
  my ($parent, $child) = $self->find_parent ($section, $path, 1);
  if (!defined $parent) {
    $self->err (ref($self) . ":hardlink: Won't create hard link to '/'\n");
    return 0;
  }

  $parent->addchildren ($node);
}


###############################################################################
# Find the child node of $self by traversing through the children @dirs.
#
# $self must refer to a section root node, and children of $self will be
# created as the appropriate sub-type.

sub find_array {
  my $self = shift;
  my $create = shift;
  my @dirs = @_;

  my ($class, $baby);

  foreach (@dirs) {
    length ($_) or next;
    if (!defined $self->{k}->{$_}) {
      $create or return undef;
      if (ref ($self) eq 'What::Node') {
	# $self is a section root -- initialize a class root
	$class = "What::Node::$_";
	$self->requireclass ($class);
	$baby = $class->new;
	$baby->setoptions ($baby->get_current_options);
      } else {
	$baby = $self->new;
      }
      $self->{k}->{$_} = $baby;
    }
    $self = $self->{k}->{$_};
  }
  return $self;
}


###############################################################################
# Find a node in the tree.  If $create>0, create intermediate nodes
# (i.e., find_node will always succeed).
#
# Can't use find_parent, because I also have to be able to find '/'

sub find_node {
  my $self = shift;
  my $section = shift;
  my $path  = shift;
  my $create = shift;

  return $self->find_array ($create, $section->split_name ($path));
}


###############################################################################
# Find a node/attribute in the tree, where the attribute is the last
# element of the given path.

sub find_node_attr {
  my $self = shift;
  my $section = shift;
  my $path  = shift;
  my $create = shift;

  my ($node, $attr) = $self->find_parent ($section, $path, $create);
  defined $node or return undef;
  exists $node->{a} or $node->{a} = {};
  exists $node->{a}->{$attr} or return undef;
  return $node->{a}->{$attr};
}


###############################################################################
# Return a tuple of the parent node and the child name
# but only if the child exists...

sub find_parent {
  my $self = shift;
  my $section = shift;
  my $path = shift;
  my $create = shift;

  my (@dirs) = $section->split_name ($path);
  my $child = pop @dirs;
  defined $child or return (undef, undef);
  my $parent = $self->find_array ($create, @dirs);
  defined ($parent) or return (undef, undef);
  return ($parent, $child);
}

###############################################################################
# Convert a file name to an array of dirs.
# Either "/" or "" means "/", which is an array with a single, empty element.

sub split_name {
  my $section = shift;
  my $file = shift;

  $file = $section->substitute_vars ($file);
  $file =~ s:/+:/:g;
  return split (/\//, $file);
}

###############################################################################

sub join_name {
  my $self = shift;
  my @dirs = @_;

  (@dirs == 1 && $dirs[0] eq '') and return '/';
  return join ('/', @dirs);
}


###############################################################################
# Generic generate method.  It's a no-op.

sub generate {
  my $self = shift;

  my ($class);
  # Get class
  $class = ref ($self);
  $class =~ s/(.*::)+//;

  $self->err ("Class $class has no generate method.\n");

  return -1;
}


###############################################################################
# Generic apply method.  It's a no-op.

sub apply {
  my $self = shift;

  # Get class
  my $class = ref ($self);
  $class =~ s/(.*::)+//;

  $self->debug (3, "Class $class has no apply method.\n");

  return 1;
}

###############################################################################
# Write out a configuration for a generic object

sub write {
  my $class = shift;
  my $section = shift;
  my $what = shift;
  my $sname = shift;
  my $cname = shift;
  my $fh = shift;

  my $inodes = [];

  $class->write_r ($section, $fh, $inodes, '/' . $cname);
}

sub write_r {
  my $self = shift;
  my $section = shift;
  my $fh = shift;
  my $inodes = shift;
  my $name = shift;

  my $inode = $self->inode;
  my $attrs = $self->getattrs ($section);
  my $children = $self->getchildren ($section);
  my ($child, $key, $have_triggers, $text);
  if (defined $inodes->[$inode]) {
    print $fh "  <hardlink path=\"$name\" source=\"$inodes->[$inode]\" />\n";
    return 1;
  }
  $inodes->[$inode] = "$name";

  # See if I have any attributes to print for this node
  if (keys %$attrs) {
    print $fh "  <node path=\"$name\" ";
    foreach $key (sort keys %$attrs) {
      if (ref ($attrs->{$key}) eq '') {
	print $fh "$key=" . $self->xmlquote ($attrs->{$key}) . " ";
      }
    }
    $have_triggers = defined ($attrs->{trigger}) &&
      ref($attrs->{trigger}) eq 'HASH';
    $text = $self->grocktext ($section);
    if ($have_triggers || defined ($text)) {
      print $fh ">\n";
      print $fh $text if defined ($text);
      $self->write_triggers ($attrs->{trigger}, $fh) if $have_triggers;
      print $fh "  </node>\n";
    } else {
      print $fh "/>\n";
    }
  }

  # Now do the recursion
  foreach $child (sort keys %$children) {
    $children->{$child}->write_r ($section, $fh, $inodes, "$name/$child");
  }
  return 1;
}

sub grocktext {
  my $self = shift;
  my $section = shift;

  my $text = $self->gettext ($section);
  return undef unless defined $text;
  $text =~ s/[\n\s]+$//g;
  $text =~ s/^[\n\s]+//g;

  $text .= "\n";
}


sub write_triggers {
  my $self = shift;
  my $triggers = shift;
  my $fh = shift;

  my ($ttag, $trigger, $tag);
  foreach $ttag (sort keys %$triggers) {
    $trigger = $triggers->{$ttag};
    print $fh "    <trigger ";
    # Print a couple of tags out of alpha order
    foreach $tag ('name', 'path') {
      defined ($trigger->{$tag}) and
	print $fh "$tag=\"$trigger->{$tag}\" ";
    }
    foreach $tag (sort keys %$trigger) {
      $tag eq 'name' || $tag eq 'path' and next;
      defined ($trigger->{$tag}) and
	print $fh "$tag=\"$trigger->{$tag}\" ";
    }
    print $fh " />\n";
  }
}


###############################################################################

1;
