# -*-perl-*-

# $Id: What.plm,v 1.35 2009/08/28 16:32:45 timc Exp $

# Take a bunch of xml description files and put them all together

=head1 NAME

What - Generic what perl module

=cut

package  What;

use strict;
use FileHandle;
use XML::Parser;
use Data::Dumper;
use File::stat;
use File::MkTemp;
use Sys::Hostname;
use Time::localtime;
use File::Spec;

use What::Node;
use What::Trigger;

our %opts = ();

###############################################################################
# Create a new object.

sub new {
  my $invocant = shift;

  my $class = ref ($invocant) || $invocant;

  requireclass ($invocant, $class) or return undef;
  bless {} => $class;
}

# Fill in the options information
sub initialize_options {
  my $self = shift;
  my %parms = ( @_ );

  my ($key, $type);
  my $class = ref ($self);

  # Copy the base options for the class
  no strict 'refs';
  $self->{opts} = {%{"${class}::opts"}};
  use strict;

  # Copy options from %main::opts for this object type
  ($type) = ($class =~ /([^:]+)$/);
  # print STDERR "Looking for options matching $type\n";
  foreach $key (keys %main::opts) {
    $key =~ /^$type\:(.*)$/i or next;
    # print STDERR "Copying $key to the new object\n";
    $self->{opts}->{$1} = $main::opts{$key};
  }

  # Now apply options from $invocant and/or %parms
  foreach $key (keys %{$self->{opts}}) {
    (exists ($parms{$key})) and $self->{opts}->{$key} = $parms{$key};
  }

  return $self;
}

###############################################################################
# Try to 'require' the requested class (if needed)
#
# Return 1 on success, 0 on failure (and print reason to STDERR)

our %doneclasses;

sub requireclass {
  my $self = shift;
  my $class = shift;

  exists $doneclasses{$class} and return 1;

  # Try to include the class they want
  eval "require $class";
  if ($@) {
    print STDERR "What: class $class not loaded.  Perl error text follows:\n$@\n";
    return 0;
  }
  $doneclasses{$class}++;
  return 1;
}


###############################################################################
# Apply the configuration at the requested root.

sub apply {
  my $what = shift;

  my ($sname, $section, $classes, $cname, $attrs, $sysname);

  # If the configuration has a sysname attribute at the root level, it must
  # match the sysname of the configuration

  $section = $what->find_section ('default');
  $attrs = $section->getattrs($section);
  if (defined $attrs->{sys}) {
    if (defined ($sysname=$what->get_target_sysname)) {
      if ($attrs->{sys} ne $sysname) {
	if ($::opts{force}) {
	  print STDERR <<__Eof__
The sysname in the configuration ($attrs->{sys}) is different
from the sysname on the target host ($sysname).  However, you have
specified --force on the what command line.

You pays your money, you takes your chances.

__Eof__
  ;
	} else {
	  print STDERR <<__Eof__
The sysname in the configuration ($attrs->{sys}) is different
from the sysname on the target host ($sysname).  If you really want
to do this, you need to specify --force on the what command line.

I am _not_ going to apply the configuration at this time.

__Eof__
  ;
	  return 0;
	} #if opts force
      } #if sysname ne
    } 
  }

  # Now apply the configuration

  foreach $sname (keys %{$what->{sections}}) {
	  $section = $what->{sections}->{$sname};
	  $classes = $section->getchildren ($section);

	  foreach $cname (keys %$classes) {
	      if (!defined $::module_priority{$cname}) {
		  $classes->{$cname}->err ("Application priority missing for class $cname!\n");
		  $::module_priority{$cname} = -1;  # Skip it
	      }
	  }
	  foreach $cname (
			  sort {$::module_priority{$b} <=> $::module_priority{$a}}
			  keys %$classes
			  ) {
	      #CSL #376699 -- 28 august 2009 timc
	      #the reason for this is that we want to have frequent updates on
	      #some workstations like instructional, mail hosts, etc.  These need
	      #to run make_passwd frequently.  What does that, but there is a lot
	      #of additional overhead with the RPMs, files, etc.  So just run the
	      #triggers when there is a 'triggeronly' argument added.
	      if ($::opts{triggeronly}) {
		  if ($cname eq "Triggers") {
		      $::module_priority{$cname} < 0 and next;
		      $classes->{$cname}->debug (1, "Applying %s...\n", $cname);
		      $classes->{$cname}->apply ($section, $what, $sname, $cname);
		  } #if triggers
	  } else {
	      $::module_priority{$cname} < 0 and next;
	      $classes->{$cname}->debug (1, "Applying %s...\n", $cname);
	      $classes->{$cname}->apply ($section, $what, $sname, $cname);
	  }
	  }
      }


	return 1;
    }

###############################################################################
# Apply a hueristic to figure out the target sysname

sub get_target_sysname {

  # If this is a fake root, just let them go
  defined ($::opts{root}) and return undef;

  # Most unixes.  run /usr/afsws/bin/sys
  # OpenAFS 1.6.x -- afsws no longer
  if (-x '/usr/bin/sys') {
    my $fh = new FileHandle "/usr/bin/sys |";
    defined ($fh) or return undef;
    my $sysname = <$fh>;
    chomp ($sysname);
    length ($sysname) and return $sysname;
  }

  # Default case, I dunno
  return undef;
}


###############################################################################
# Generate an error message, regardless of the debug level

sub err {
  my $self = shift;
  my @message = (@_);

  if (!printf STDERR @message) {
    printf STDERR "Oooops!\n";
  }
  return 1;
}


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

sub debug {
  my ($self, $level, @message) = (@_);

  defined ($level) or return $self->err(@message);
  my $debug = $self->getoption ('debug');
  $debug = 1 unless defined $debug;
  $level <= $debug and return $self->err(@message);
  return 0;
}


###############################################################################
# Return a specific or generic option for this class.

sub getoption {
  my $class = shift;
  my $tag = shift;
  my @modules = @_;

  (exists ($class->{o}) &&
   exists ($class->{o}->{$tag}) &&
   defined ($class->{o}->{$tag}))
    and return $class->{o}->{$tag};
  exists ($::opts{$tag}) && defined ($::opts{$tag})
    and return $::opts{$tag};

  return undef;
}


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

# This begins the section devoted to the language-parsing methods.

=head1 XML FORMAT

An XML language is used to specify system configurations.  The name of
the root node is irrelevant, but B<E<lt>whatE<gt>> is used by
convention.

<what [I<name>="I<value>" ...]>
</what>

Attributes of the root node function as default values for local
variable within the context of the current document and any documents
included within the current document.  These values may be overridden
by the B<vars> clause in the B<include> directive (see below).  When
processing of the current document is complete, the variables either
revert to their previous values (if they existed), or are removed (if
they didn't exist).

The majority of the langues consists of directives contained in nodes
in the body of the XML document.  These are:

=over 4

=cut

###############################################################################
# Merge method for all data types
# $self is the section that this node should be included in.

sub merge {
  my $section = shift;
  my $what = shift;
  my $include_tree = shift;
  my $maxdepth = shift;
  my $tag = shift;
  my $content = shift;


  my $node = shift @$content;

  # Walk through content, saving the first non-whitespace '0' tag found
  my $i=0;
  my ($t, $c, $text);
  while (defined $content->[$i]) {
    $t = $content->[$i++];
    $c = $content->[$i++];
    next unless $t eq '0';
    next if $c =~ /^[\n\s]*$/;
    $text = $c;
    last;
  }

  if (($tag =~ /^node$/i) || ($tag =~ /^replace$/i)) {
    if (defined $node->{path}) {
      my ($path, $newnode, $triggers);
      $path = $node->{path};
      delete $node->{path};
      ($tag =~ /^replace$/i)
	and $section->clearattrs ($section, $node, $path, 0);
      $newnode = $section->setattrs ($section, $node, $path, 1);
      defined ($triggers = $newnode->parse_trigger ($section, $content))
	and $newnode->setattrs ($section, {trigger => $triggers});
      $newnode->settext ($section, $text) if defined ($text);
    }	

  } elsif ($tag =~ /^delete$/i) {
    $section->do_delete ($section, $node, $content);

  } elsif ($tag =~ /^hardlink$/i) {
    $section->hardlink ($node->{path}, $node->{source});

  } elsif ($tag =~ /^setattr$/i) {
    $section->setattr ($section, $node, $content);

  } elsif ($tag =~ /^chmod$/i) {
    $section->do_chmod ($section, $node, $content);

  } elsif ($tag =~ /^include$/i) {
    # Make the vars vars + ($content except name/dir)
    my $vars = getvars ($content);
    foreach (keys %$node) {
      /^(name|dir)$/ and next;
      $vars->{$_} = $node->{$_};
    }
    if (exists ($node->{dir}) && defined ($node->{dir})) {
      $what->include_path (1, $node->{dir});
    }
    if (exists ($node->{name}) && defined ($node->{name})) {
      $section->include ($what, $include_tree, $maxdepth, $vars, $node->{name});
    }

  } elsif ($tag =~ /^section$/i) {
    $what->section ($include_tree, $maxdepth, $node, $content);

  } elsif ($tag =~ /^mv$/i) {
    $section->mv ($section, $node->{from}, $node->{to}, 0);
  } elsif ($tag =~ /^merge$/i) {
    $section->mv ($section, $node->{from}, $node->{to}, 1);
  }
}


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

=item include

 <include [dir="I<include directory>"]
          [name="<what object>"]
          [dontwhine="(1|0)"] >
   [<vars [I<name>="I<value>" ...] />]
 </include>


If the B<dir> attribute is given, it's value is a directory that is
added to the module search path.  The new directory is given the
highest priority in the search path.

If the B<name> attribute is given, it's value is an object that should
be included in the configuration tree before any more of the current
file is parsed.  B<name> can be a full path name, in which case no
search path is used, or it can be a relative name, in which case a
file with that name is searched for in each directory in the search
path.  If the B<.xml> extension is not specified, it is added before the
check is made.  Thus, B<all> content files in the system must end in
B<.xml>.

The B<dontwhine> attribute is a boolean.  If true, what will not
complain (by printing a message on stderr) if it can't find the file.
(It actually does this by changing the debug level of the message from
1 to 2, so you can still get the messages by setting the debug level
higher at program invocation).

If a B<vars> clause is present, the variable(s) listed by B<name> will
be set in the root node of the current section.  When the include is
completed, attributes listed in the B<vars> clause are reverted to
their original values, or removed if they had not existed previously.

As a convenience, any attributes other than B<dir> and B<name> can be
set either in the B<vars> clause or in the B<include> itself.  Thus,
the following are completely equivalent in function:

  <include name="stash-ticket" st_user="strivia" />

and

  <include name="stash-ticket" >
    <vars st_user="strivia" />
  </include>

=cut

# Returns the number of objects that were found and that contained
# valid XML.

# The include_tree provides a tree reference of included modules.
# Maxdepth ignores (but includes in include_tree) any includes after 
#  a certain depth.

# $vars is a hashref that provides names/values of variables that should be
# set in the current section for the duration of this include, and then
# reset before leaving...

sub include {
  my $section = shift;
  my $what = shift;
  my $include_tree = shift;
  my $maxdepth = shift;
  my $vars = shift;
  my @objects = @_;

  # Include the passed objects
  my $included=0;
  my $dontwhine = $vars->{dontwhine} || 0;
  my ($object, $target);
  foreach $object (@objects) {
    $object = $section->substitute_vars ($object);
    my ($xml, $filename) = $what->readobj ($section, $object, $dontwhine);
    defined ($xml) or next;

    # Update the target variable with the first object included
    $section->settarget ($what, $object);

    $include_tree->{kids}->{$object}->{filename} = $filename;
    ($maxdepth == 0) and next;
    $section->mergeXML ($what,
			$include_tree->{kids}->{$object},
			$maxdepth-1,
			$vars,
			$xml);
    $included++;
  }

  return $included;
}


# Get the variables out of the include line
sub getvars {
  my $xml = shift;

  my ($tag, $content);
  my $vars = {};
  while (@$xml) {
    $tag = shift @$xml;
    $content = shift @$xml;
    $tag eq 'vars' or next;
    $content = shift @$content;
    foreach (keys %$content) {
      $vars->{$_} = $content->{$_};
    }
  }
  return $vars;
}


# Set the target variable according to the current rules.  Return the target.
# If it's already set, don't change it; just return the current value.
sub settarget {
  my $section = shift;
  my $what = shift;
  my $target = shift;

  my $current_target = $section->find_node_attr ($section, '/target', 0);
  if (defined $current_target) {
    return $current_target;
  }

  if (defined $::opts{target}) {
    # Prefer to set target to the value passed on the command line
    $section->setattrs ($section, { target => $::opts{target} });
    return $::opts{target};
  }

  $section->setattrs ($section, { target => $target });
  return $target;
}

###############################################################################
# Find and read in the passed configuration file.
# If there are no '.'s in the name, supply the default extension.
# If there are no directory dividers, look along the library path
# for the specified object.
#
# Return the appropriate xml, or undef on error
sub readobj {
  my $what = shift;
  my $section = shift;
  my $object = shift;
  my $dontwhine = shift;

  my ($l, $lib, $file);

  $object = $section->substitute_vars ($object);
  if ($object =~ /^\//) {
    # Object is a full path name
    if ($object =~ /\.xml$/ && -f $object) {
      return readfile ($what, $object, $object);
    } elsif (-f "$object.xml") {
      return readfile ($what, "$object.xml", $object);
    }
  } else {
    # Start search path
    foreach $l (@{$what->include_path}) {
      $lib = $section->substitute_vars ($l);
      if ($object =~ /\.xml$/ && -f "$lib/$object") {
        return readfile ($what, "$lib/$object", $object);
      } elsif (-f "$lib/$object.xml") {
        return readfile ($what, "$lib/$object.xml", $object);
      }
    }
  }
  $what->debug (
		$dontwhine?2:1,
		"Can't find xml file for $object...Sorry\n",
	       );
  return (undef, undef);
}


sub readfile {
  my $what = shift;
  my $file = shift;
  my $object = shift;

  my ($ret);

  $what->debug (2, "Using file $file for $object...\n");
  my $p = new XML::Parser (Style=>'Tree');
  eval { $ret = $p->parsefile ($file) };
  if ($@) {
    $what->err ("Failed to parse xml file $file:\n%s\n", $@);
    $ret = undef;
  }
  return ($ret, $file);
}

###############################################################################
# Add the passed paths to $self->{include_path}
sub include_path {
  my $what = shift;

  if (@_) {
    # We're going to set the include path
    my $attop = shift;
    my @incs = @_;
    my $inc;

    foreach $inc (@incs) {
      foreach (split /:/, $inc) {
	# (-d $_) or $what->err ("Warning... Can't find include path $_ for now...\n");
	if ($attop) {
	  unshift @{$what->{include_path}}, $_;
	} else {
	  push @{$what->{include_path}}, $_;
	}
      }
    }
  } else {
    # Just return the current path
    defined ($what->{include_path})
      or $what->{include_path} = [];
    return [@{$what->{include_path}}];
  }
}

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


# Merge the list of xml references into this section.
sub mergeXML {
  my $section = shift;
  my $what = shift;
  my $include_tree = shift;
  my $maxdepth = shift;
  my $vars = shift;
  my $xml = shift;

  # Skip the master node goo
  shift @$xml;       # Skip document name
  $xml = shift @$xml;  # Use document content

  my $root_attrs = shift @$xml;
  my $old_root_attrs = $section->getattrs ($section);

  my ($save_attrs, $remove_attrs, $set_attrs, $attr) = ({}, {}, {}, undef);
  # Apply variable substitution for this document.  The rules are:
  # -- If an attribute is in $vars, set it.
  # -- If not in $vars, but in $root_attrs, set it from there.
  # Always restore values at the end of this document.
  foreach $attr (keys %$root_attrs) {
    # Don't use it if $vars has it
    exists ($vars->{$attr}) and next;
    # Set it, but know what to do when I'm done.
    $set_attrs->{$attr} = $root_attrs->{$attr};
    if (exists $old_root_attrs->{$attr}) {
      $save_attrs->{$attr} = $old_root_attrs->{$attr};
    } else {
      $remove_attrs->{$attr} = 1;
    }
  }
  foreach $attr (keys %$vars) {
    $set_attrs->{$attr} = $vars->{$attr};
    if (exists ($old_root_attrs->{$attr})) {
      $save_attrs->{$attr} = $old_root_attrs->{$attr};
    } else {
      $remove_attrs->{$attr} = 1;
    }
  }

  $section->setattrs ($section, $set_attrs);


  my $retval = $section->merge_content ($what, $include_tree, $maxdepth, $xml);

  # Restore old values
  $section->un_link ($section, '', keys %$remove_attrs);
  $section->setattrs ($section, $save_attrs);

  return $retval;
}


# Verify the new section and populate it
sub section {
  my $what = shift;
  my $include_tree = shift;
  my $maxdepth = shift;
  my $node = shift;
  my $xml = shift;

  defined ($node->{name}) && length ($node->{name}) or return -1;
  my $section_name = $node->{name};
  my $section = $what->find_section ($section_name, 1);
  exists ($section->{tree}) or $section->{tree} = new What::Node ();

  my $req;
  if (exists $node->{requires}) {
    foreach $req (keys %{$node->{requires}}) {
      $section->{requires}->{$req} = 1;
    }
  }
  return $section->merge_content ($what, $include_tree, $maxdepth, $xml);
}


# Merge the tag, content pairs into the passed section
sub merge_content {
  my $section = shift;
  my $what = shift;
  my $include_tree = shift;
  my $maxdepth = shift;
  my $xml = shift;

  my ($tag, $content);
  # Now work through tag, content pairs
  while (@$xml) {
    $tag = shift @$xml;
    $content = shift @$xml;
    # Skip text nodes at this level
    ($tag eq '0') and next;
    $section->merge ($what, $include_tree, $maxdepth, $tag, $content);
  }
  return 1;
}


###############################################################################
# Find a section by name.

sub find_section {
  my $what = shift;
  my $section_name = shift;
  my $create = shift;

  exists ($what->{sections}) or $what->{sections} = {};
  if (!exists ($what->{sections}->{$section_name}) ||
      !defined ($what->{sections}->{$section_name})) {
    $create or return undef;
    $what->{sections}->{$section_name} = new What::Node;

  }
  return $what->{sections}->{$section_name};
}

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

=item mv

<mv from="I<from_path>" to="I<to_path>" />

The B<mv> directive causes a piece of the configuration tree to be
picked up and moved from one location to another.  Any previous
contents at the destination will be lost (despair not: see the
B<merge> directive, below).

=item merge

<merge from="I<from_path>" to="I<to_path>" />

The B<merge> directive causes a piece of the configuration tree to be
removed from its current location (B<from_path>) and merged into another
part of the tree (B<to_path>).  Any attributes at B<to_path> (or its children)
will be replaced by the equivalent attributes from the corresponding
node in B<from_path>, and any children of B<to_path> will be merged with the
corresponding children in B<from_path>.

=cut

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

=item hardlink

<hardlink path="I<destination>" source="I<source>" />

The hardlink directive creates a hard link in the configuration tree.
The node referred to at I<source> must exist when the hardlink
directive is encountered.

=cut

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

=item delete

<delete path="I<path>" [attrs="I<attr>[,I<attr>...]"] >

<delete [attrs="I<attr>[,I<attr>...]"] >
  <where attr="I<attr>" value="I<value>" [match="exact|perlre"] />
    . . .
</delete>

In either form of the delete directive, B<attrs> is a list of
attributes to delete.  If no attributes are listed, the entire node
(and any children) are removed.

In the first form, B<path> is an exact path.  In the second form,
multiple where clauses can be specified (see the section on the
I<where clause>, below).  Thus, the two directives are equivalent:

<delete path="/Files/etc/foo" attrs="md5sum" />

<delete attrs="md5sum" >
  <where attr="path" value="/Files/etc/foo" match="exact" />
</delete>

Data will only be deleted if all where clauses are matched.

=cut

sub do_delete {
  my $self = shift;
  my $section = shift;
  my $node = shift;
  my $content = shift;

  my $delete = $self->delete_parsechanges ($node, $content);


  if (!exists ($delete->{where}->{path}) ||
      (exists ($delete->{where}->{path}->{match}) &&
       $delete->{where}->{path}->{match} eq 'perlre')) {
    return $self->delete_r ($section, '/', $delete);
  }

  # Otherwise, the delete will apply to at most one node
  my $path = $delete->{where}->{path}->{value};
  my ($parent, $child) = $self->find_parent ($section, $path, 0);

  defined ($parent) or return 0;
  return $parent->delete_child ($section, $path, $child, $delete);
}


sub delete_parsechanges {
  my $self = shift;
  my $node = shift;
  my $xml = shift;

  my ($tag, $content, $attr, $where);
  my $delete = {
		where => {},
		attrs => {},
	       };

  # Check for attributes in the node proper
  foreach $tag (keys %$node) {
    $tag =~ lc ($tag);
    if ($tag eq 'path') {
      $delete->{where}->{$tag} = { value => $node->{$tag} };
    } elsif ($tag eq 'attrs') {
      foreach $attr (split /,/, $node->{$tag}) {
	$attr =~ s/^\s+//;
	$attr =~ s/\s+$//;
	length ($attr) or next;
	$delete->{attrs}->{$attr} = 1;
      }
    }
  }

  # Check for where clauses
  $self->parse_where_clause ($delete, $xml);

  return $delete;
}


sub delete_r {
  my $self = shift;
  my $section = shift;
  my $path = shift;
  my $delete = shift;

  my ($children, $child);

  # bootstrap
  $path='' if $path eq '/';

  $children = $self->getchildren ($section);
  foreach $child (keys %$children) {
    $self->delete_child ($section, "$path/$child", $child, $delete);
    exists ($children->{$child})
      and $children->{$child}->delete_r ($section, "$path/$child", $delete);
  }
}


sub delete_child {
  my $self = shift;
  my $section = shift;
  my $path = shift;   # The acsii path to the node
  my $child = shift;  # a child name (the last name in $path)
  my $delete = shift; # The delete data structure

  my ($node, $key, @attrs, $attr);

  # Check any other clauses
  defined ($node = $self->find_node ($section, $child)) or return 0;

  $self->check_where_clause ($section, $path, $delete->{where}) or return 0;

  (@attrs) = grep (!/^path$/, keys %{$delete->{attrs}});

  # Passed the where clause -- "delete the needful".  If @attrs exists,
  # only those attrs will be delete; otherwise, the node will be.
  # This is exactly what we want.
  $self->un_link ($section, $child, @attrs);
  return 1;
}


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

=item chmod

<chmod path="I<path>" setbits="I<bits>" clearbits="I<bits>" />

<chmod setbits="I<bits>" clearbits="I<bits>" >
  <where attr="I<attribute>" value="I<value>" match="exact|perlre" />
  . . .
</chmod>

The chmod command handles the special needs of the octal bit-masked
B<mode> field in many nodes in the B<Files> portion of the
configuration tree.

The two forms of the command meet different needs of complexity in
selecting nodes to modify.  The B<setbits> and B<clearbits> values are
octal numbers.

If you need to set a specific value in the mode attribute, consider
using either the B<setattr> or B<node> directives.

See the section on the I<where clause> for specifics on its usage.

=cut

sub do_chmod {
  my $self = shift;
  my $section = shift;
  my $node = shift;
  my $content = shift;

  my $changes = $self->chmod_parsechanges ($node, $content);

  if (!exists ($changes->{where}->{path}) ||
      (exists ($changes->{where}->{path}->{match}) &&
       $changes->{where}->{path}->{match} eq 'perlre')) {
    return $self->chmod_r ($section, '/', $changes);
  }

  # Otherwise, the changes will apply to at most one node
  my $cwd = $self->findNode ($changes->{where}->{path}->{value}, 0);
  defined ($cwd) or return 0;
  return $self->chmod_simple ($section, $changes->{where}->{path}->{value}, $cwd, $changes);
}

sub chmod_parsechanges {
  my $self = shift;
  my $node = shift;
  my $xml = shift;

  my $changes = {
		 where => {},
		};
  my ($tag, $content, $attr, $subst, $where);

  # Get set/clear-bits from $node itself
  foreach $tag (keys %$node) {
    $tag =~ lc ($tag);
    if ($tag eq 'path') {
      $changes->{where}->{$tag} = { value => $node->{$tag} };
    } elsif ($tag eq 'setbits' || $tag eq 'clearbits') {
      $changes->{$tag} = $node->{$tag};
    }
  }

  $self->parse_where_clause ($changes, $xml);

  (defined $changes->{clearbits}) and
    $changes->{clearbits} = oct ($changes->{clearbits});
  (defined $changes->{setbits}) and
    $changes->{setbits} = oct ($changes->{setbits});
  return $changes;
}


sub chmod_r {
  my $self = shift;
  my $section = shift;
  my $path = shift;
  my $changes = shift;

  my ($attr, $children, $child);

  # KISS -- just check this node...
  $self->chmod_simple ($section, $path, $changes);

  # Recurse...
  $path eq '/' and $path = '';
  $children = $self->getchildren;
  foreach $child (sort keys %$children) {
    $children->{$child}->chmod_r ($section, "$path/$child", $changes);
  }
}


sub chmod_simple {
  my $self = shift;
  my $section = shift;
  my $path = shift;
  my $changes = shift;

  my $mode;

  # Don't change something unless there's already a mode attribute
  defined ($mode = $self->getattrs ($section, attr => 'mode')) or return 0;
  $mode = oct $mode;

  $self->check_where_clause ($section, $path, $changes->{where}) or return 0;

  exists ($changes->{clearbits}) && defined ($changes->{clearbits}) and
    $mode &= ~$changes->{clearbits};
  exists ($changes->{setbits}) && defined ($changes->{setbits}) and
    $mode |= $changes->{setbits};
  $self->setattrs ($section, {mode => sprintf ("0%lo", $mode)});
}

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

=item node

<node path="I<path>" [I<attr>="I<value>" [...]] />

<node path="I<path>" [I<attr>="I<value>" [...]] >
  <trigger .../>
  . . .
</node>

This directive is used either to create a node in the configuration
tree, or to set values to one or more attributes on an existing node.
Any number of B<attr/value> pairs may be specified.  The B<path>
attribute is the only required attribute, and gives the location in
the configuration tree be added/modified.

Intermediate directory nodes in B<path> will be created as needed to
reach the terminal node.  These implicit directory nodes will have a
null attribute set.

A node directive may also have any number of B<trigger> clauses
attached to it; see the section below on B<trigger clause processing>.


=item replace

<replace path="I<path>" [I<attr>="I<value>" [...]] />

<replace path="I<path>" [I<attr>="I<value>" [...]] >
  <trigger .../>
  . . .
</replace>

The B<replace> directive is similar to the B<node> directive in that
it will create or update attributes of the node specified by the
B<path> attribute.  When a B<replace> directive is encountered, it
will first clear any existing attributes from the node before setting
the specified attributes.

=cut

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

=item setattr

<setattr I<attr>="I<value>" [...] >
  <where attr="I<attr>" value="I<value>" [match="exact|perlre"] />
  . . .
  <subst attr="I<attr>" oldvalue="I<old value>" newvalue="I<new value>" />
  . . .
</setattr>

The B<where> clause determines which nodes will be modified (see
I<where clause processing> below).

Attribute/value pairs listed after the B<setattr> directive cause
those attributes to be set in each node matched in the where clause.
The attribute will be added to the target node(s) if it does not
currently exist.  Any number of B<attr,value> pairs may be specified.

The optional B<subst> directive is used to perlform a perl
substitution on an attribute.  This directive can be repeated any
number of times to substitute multiple attributes in a single pass.
If a node does not currently have the attribute listed in the B<subst>
directive, that attribute will B<not> be added.

=cut

sub setattr {
  my $self = shift;
  my $section = shift;
  my $node = shift;
  my $content = shift;

  my $changes = $self->setattr_parsechanges ($node, $content);

  if (!exists ($changes->{where}->{path}) ||
      (exists ($changes->{where}->{path}->{match}) &&
       $changes->{where}->{path}->{match} eq 'perlre')) {
    return $self->setattr_r ($section, '/', $changes);
  }

  # Otherwise, the changes will apply to at most one node
  my $cwd = $self->findNode ($section, $changes->{where}->{path}->{value}, 0);
  defined ($cwd) or return 0;
  return $cwd->setattr_simple ($section, $changes->{where}->{path}->{value}, $changes);
}

sub setattr_parsechanges {
  my $self = shift;
  my $node = shift;
  my $xml = shift;

  my $changes = {
		 where => {},
		 set   => {},
		};
  my ($tag, $content, $attr, $subst, $where);

  # Check internal node hash (treat as 'set' parameters)
  foreach $tag (keys %$node) {
    if ($tag eq 'path') {
      $changes->{where}->{$tag} = { value => $node->{$tag} };
    } else {
      $changes->{set}->{$tag} = { value => $node->{$tag} };
    }
  }

  # Check for where clauses
  $self->parse_where_clause ($changes, $xml);

  # Check for subst clauses
  while (@$xml) {
    $tag = lc (shift @$xml);
    $content = shift @$xml;

    if ($tag =~ /^subst$/) {
      $subst = $content->[0];
      (defined ($subst->{attr}) &&
       defined ($subst->{oldvalue}) &&
       defined ($subst->{newvalue})) or next;
      $changes->{set}->{$subst->{attr}} = {
					   oldvalue => $subst->{oldvalue},
					   newvalue => $subst->{newvalue},
					  };
    }
  }
  return $changes;
}


sub setattr_r {
  my $self = shift;
  my $section = shift;
  my $path = shift;
  my $changes = shift;

  my ($attr, $child, $children);

  # Because we're here, either:
  #  path isn't in the where clause, --or--
  #  path is a perlre match
  if (!exists ($changes->{where}->{path}) ||
      ($path =~ $changes->{where}->{path}->{value})) {
    $self->setattr_simple ($section, $path, $changes);
  }

  # Recurse...
  $path eq '/' and $path = '';
  $children = $self->getchildren ($section);
  foreach $child (sort keys %$children) {
    $children->{$child}->setattr_r ($section, "$path/$child", $changes);
  }
}


sub setattr_simple {
  my $self = shift;
  my $section = shift;
  my $path = shift;
  my $changes = shift;

  my ($key, $value, $set, $oldvalue, $newvalue, $fromvalue, $tovalue);

  $self->check_where_clause ($section, $path, $changes->{where}) or return 0;

  # All matched -- set things we're supposed to set
  foreach $key (keys %{$changes->{set}}) {
    $set = $changes->{set}->{$key};
    if (exists $set->{value}) {
      $self->setattrs ($section, {$key => $set->{value}});
    }
    if (exists $set->{oldvalue}) {
      $fromvalue = $tovalue = $self->getattrs ($section,  attr => $key );
      if (defined $fromvalue) {
	($oldvalue, $newvalue) = ($set->{oldvalue}, $set->{newvalue});
	$tovalue =~ s/$oldvalue/$newvalue/;
	($fromvalue eq $tovalue) or $self->setattrs ($section, {$key => $tovalue});
      }
    }
  }
  return 1;
}

###############################################################################
###############################################################################
# End language directive section

###############################################################################
# returns 1 if the where clause is satisfied, 0 if not

=item where clause processing

The where clause is not a directive of its own but a component of
other directives.  Some of the language directives can include one or
more where clauses to allow fine-grained selection of appropriate
nodes.  The format of the where clause is:

  <where attr="I<attribute>" value="I<value>" match="I<perlre>" />

The B<attr> attribute indicates the attribute to match in the tree
node.  The B<value> attribute gives the value that the node attribute
must have to be selected.  The B<match> attribute gives the type of
match, which should be one of the keywords B<exact> or B<perlre>.
Matches are assumed to be B<exact> unless otherwise indicated.

Where B<where> clauses are permitted, any number can be specified.
All where clauses must be satisfied for the directive to continue.

Note that a directive without a B<where> clause for the B<path>
attribute, and a where clause with a B<perlre> match on the
B<path> attribute, currently involve walking the entire configuration
tree for each such directive, so care needs to be taken to avoid CPU wastage.

=cut

sub check_where_clause {
  my $self = shift;
  my $section = shift;
  my $path = shift;    # ascii name of the path
  my $where = shift;   # hashref of attrs=> (value+match)

  my ($key, $value);

  foreach $key (keys %$where) {
    # Skip a non-existent attribute
    if ($key eq 'path') {
      $value = $path;
    } else {
      defined ($value = $self->getattrs ($section, attr => $key)) or return 0;
    }
    if (exists ($where->{$key}->{match}) &&
	defined ($where->{$key}->{match}) &&
	$where->{$key}->{match} eq 'perlre') {
      $value =~ $where->{$key}->{value} or return 0;
    } else {
      $value eq $where->{$key}->{value} or return 0;
    }
  }
  return 1;
}

# Check the passed $xml for where clauses, and add them to
# the passed $node.

sub parse_where_clause {
  my $self = shift;
  my $node = shift;
  my $xml = shift;

  my ($tag, $content, $attr, $where);
  my $index=0;

  while ($index < @$xml) {
    $tag = $xml->[$index++];
    $content = $xml->[$index++];
    if ($tag eq 'where') {
      $where = $content->[0];
      defined ($where->{attr}) &&
	defined ($where->{value}) or next;
      $node->{where}->{$where->{attr}} = {
					  value => $where->{value},
					  match => $where->{match},
					 };
    }
  }
}

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

=item trigger clause processing

Any node may incorporate one or more B<trigger> clauses.  The format of
the target clause is:

  <trigger path="B<trigger path>" [B<attr>="B<value>" [...]] />

The path specified by the B<path> attribute references a node that has
been created in the I</Triggers/...> portion of the configuration
tree.  An error will be reported, and no trigger will be run, if such
a node does not exist.  The trigger can be passed an arbitrary set of
attributes, specified by the remaining attribute/value pairs in the
trigger node.

The What::Node::Triggers man page gives more detailed
information on creating and activating trigger nodes.

The What::Trigger man page, and the man pages for the internal
(perl module) triggers What::Trigger::* provide more
information on internal triggers

=cut

# Check the content of a node for trigger clause(s)

sub parse_trigger {
  my $self = shift;
  my $section = shift;
  my $xml = shift;

  my ($tag, $content, $attr, $trigger);
  my $index=0;
  my $triggers = {};

  while ($index < @$xml) {
    $tag = $xml->[$index++];
    $content = $xml->[$index++];
    if ($tag eq 'trigger') {
      $trigger = bless {} => "What::Trigger";
      foreach $attr (keys %{$content->[0]}) {
	$trigger->{$attr} = $section->substitute_vars (scalar $content->[0]->{$attr});
      }
      if (!exists $trigger->{path}) {
	$self->err ("Trigger found with no path attribute -- skipping\n");
	next;
      }	
      if (exists $trigger->{name}) {
	$triggers->{$trigger->{name}} = $trigger;
      } elsif (exists $trigger->{path}) {
	$triggers->{$trigger->{path}} = $trigger;
      }
    }
  }
  keys (%$triggers) and return $triggers;
  return undef;
}

# Run triggers as appropriate.  $self is a Node::<foo> object.
# $path is the path to $self.
sub run_triggers {
  my $self = shift;
  my $section = shift;
  my $what = shift;
  my $path = shift;

  my ($tag, $triggers, $trigger, $widget, @keys);

  defined ($triggers = $self->getattrs ($section, attr => 'trigger')) or return 0;

  eval {@keys = keys %$triggers};
  return 0 if $@;
  @keys or return 0;

  foreach $tag (@keys) {
    $trigger = $triggers->{$tag};
    if ($self->getoption ('donothing')) {
      $self->debug (2, "Skipping trigger %s for node %s\n", $trigger->{path}, $path);
    } else {
      $self->debug (3, "Running trigger %s for node %s\n", $trigger->{path}, $path);
      $trigger->run (
		     $self,
		     $section,
		     $what,
		     {
		      %$trigger,
		      nodepath => $path,
		     }
		    );
    }
  }
}


###############################################################################
# Write the configuration out to the requested file handle

sub write {
  my $what = shift;
  my $file = shift;

  my ($sname, $cname);
  my $fh = new FileHandle ">$file";
  defined ($fh) or $what->err ("Can't open $file for writing!\n");

  print $fh "<What>\n\n";
  foreach $sname (sort keys %{$what->{sections}}) {
    $sname eq 'default' or print " <Section name=\"$sname\">\n";
    my $section = $what->{sections}->{$sname};
    my $classes = $section->getchildren ($section);
    foreach $cname (sort keys %$classes) {
      $classes->{$cname}->write ($section, $what, $sname, $cname, $fh);
    }
    $sname eq 'default' or print " </Section>\n\n";
  }
  print $fh "\n</What>\n";

  return 1;
}


###############################################################################
# End pod section

=back

=cut

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

=head1 VARIABLES

B<Variables> can be used in B<what> to substitute the value of a node
attribute in an alternate location.  A variable reference consists of
a dollar sign ($) followed immediately by a path reference surrounded
by curly braces ({}).  The final element of the path is an attribute
name, and the remainder of the path points to an existing B<what>
node.

By convention, simple variables are stored as attributes in the root
node of the configuration tree.  Thus, references to simple variables
can be indicated as ${/var}, or even more simply, ${var}.

Thus, to install a file in root's home directory, an appropriate
attribute is initialized for each architecture:

<node path="/" root_home="/root" />

Then the file can be installed in an architecture-independent manner:

<node path="${root_home}/foo" source= . . . />

Variables included in path attributes are evaluated when the
configuration is merged.  In most circumstances, however, variable
substitution occurs when the configuration is applied.

In a different context, if an imaginary part of the configuration tree
existed which contained the ip addresses for a host:

<node path="/Ip/interfaces/0" ip="128.105.162.34" />
<node path="/Ip/interfaces/1" ip="128.105.3.12" />

This value could be bound in an abstract manner to a internet service:

<node path="/Inetd/ftp" bind="${/Ip/interfaces/0/ip}" />

=head1 AUTOMATIC VARIABLES

The following variables are filled in automatically by B<what>.  They
can be changed by the merged configuration data, but this is strongly
discouraged:

=over 4

B<target> is the name of the first XML object included by the
configurator B<as it was originally specified>.  This is most useful
when this name is the name of the host to configure.

=back

=head1 STANDARD VARIABLES

Although not automatically defined, there are many more standard
variables that should be set on a per architecture basis.

=over 4

B<processor>, B<nodename>, B<release>, and B<sysname> should contain
values that correspond to the B<uname> (2) system call for the
appropriate architecture.

B<root_home> The superuser's home directory.

B<inet_dir> The directory where internet configuration files reside.

B<var_dir> The mount point for the B</var> file system.

B<rc_dir> The directory that contains the system rc scripts.

B<rc_link_root> The directory that contains the rc?.d directories

=back

=cut

# Update variables of the form ${<var>} in the
# passed expression from other configuration data.

# A variable is:
# - a dollar sign ($) followed by
# - a left curly brace  followed by
# - a path in the configuration tree followed by
# - a right curly brace

# The final element in the path is an attribute that must exist in a node
# composed of all the other elements in the path

sub substitute_vars {
  my $section = shift;
  my $string = shift;

  defined ($string) or return undef;
  ref($string) and return $string;

  my $output = '';
  my ($var, $value);

  # Parse, parse, parse
  while (1) {

    # Peel off everything up to and including the first '$'
    if ($string =~ s'^([^$]*)\$'') {
      $output .= $1;

      # $$ is a literal '$'
      if ($string =~ s/^\$//) {
	$output .= '$';
	next;

	# Next check for ${<var>}
      } elsif ($string =~ s/^\{([a-zA-Z\/][\w\/]*)\}//) {
	$var = $1;
	# Now look up $var and do the stuff
	$value = $section->find_node_attr ($section, $var, 0);
	if (defined $value) {
	  $output .= $value;
	}
	# Try replacing it with nothing if it doesn't exist
	#else {
	# It doesn't exists - push the stuff back onto the output
	# $output .= '${' . $var . '}';
	# }

      } else {
	# Put the '$' back on the output stream
	$output .= '$';
	next;

      }
    } else {
      # No more substitutions
      $output .= $string;
      return $output;
    }
  }
}




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

# Finish off the pod documentation

=head1 SEE ALSO

What(1)

=cut

###############################################################################
# Check whether an attribute value is true

sub checkbool {
  my $self = shift;
  my $attr = shift;

  defined ($attr) or return 0;
  $attr =~ /^(true|on|yes|1)$/i and return 1;
  return 0;
}

###############################################################################
# Quote out '"' and '&' characters in xml strings

sub xmlquote {
  my $self = shift;
  my $string = shift;

  $string =~ s/\&/\&amp;/g;
  $string =~ s/\"/\&quot;/g;
  $string =~ s/\</&lt;/g;
  $string =~ s/\>/&gt;/g;
  "\"$string\"";
}


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

# Check and replace the content of a file under revision control.

# $revision_control_type can be one of:
# 'RCS' -- use RCS revision control
# 'CVS' -- use CVS revision control
# undef -- look for CVS or RCS directories (and use the appropriate method),
#          or fall back to RCS as a last resort.

# Ain't the name of the method a mouthful?

sub check_and_replace_content_revision_control {
  my $self = shift;
  my $fname = shift;
  my $content = shift;
  my $minsize = shift;
  my $makebackup = shift;
  my $revision_control_type = shift;

  my $res = $self->check_and_replace_content
    ($fname, $content, $minsize, $makebackup);
  return $res unless $res>0;

  my ($vol, $dirs, $file) = File::Spec->splitpath ($fname);
  # Check revision control type
  if (!defined $revision_control_type) {
    # Heurstic -- try CVS first, otherwise it's RCS of one type or another...
    my $fname2 = File::Spec->catpath ($vol, $dirs, 'CVS');
    $revision_control_type = (-d $fname2) ? 'CVS' : 'RCS';
  }

  my $dir1 = File::Spec->catpath ($vol, $dirs, '');
  if ($revision_control_type eq 'CVS') {
    $self->do_system ("/bin/sh -c \"cd $dir1 ; /s/what-0.1.31/depend/cvs commit -m 'auto-commit by What::Cricket' $file\"");
  } else {
    # Fake this a little
    my $fname4 = mktemp ("${file}XXXXXX", $dir1);
    $self->do_system ("/bin/sh -c \"cd $dir1 ; mv $file $fname4 ; /s/what-0.1.31/depend/co -l $file ; mv $fname4 $file ; /s/what-0.1.31/depend/ci -u '-mauto-commit by What::Cricket' $file\"");
  }
  return $res;
}


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

# Check the file $fname.  If it doesn't contain the content passed in $content,
# create a new version containing $content

# Return one if the file was updated, zero otherwise.

sub check_and_replace_content {
  my $class = shift;
  my $fname = shift;
  my $content = shift;
  my $minsize = shift;
  my $makebackup = shift;
  my $uid = shift;
  my $gid = shift;
  my $mode = shift;

  my ($st, $fh, $newname, $oldcontent);
  my $filename = (defined ($::opts{root}) ? $::opts{root} : '') . $fname;

  lstat ($filename);
  if (-f _) {
    $st = stat ($filename);
    if (defined ($fh = new FileHandle $filename, "r")) {
      sysread ($fh, $oldcontent, $st->size);
      return $class->check_uid_gid_mode ($filename, $uid, $gid, $mode) if $oldcontent eq $content;
    }
  }

  if ($class->getoption ('donothing')){
    $class->debug (1, "Would replace $filename\n");
    return 1;
  }

  if (defined ($minsize) && length ($content) < $minsize) {
    $class->err ("Cowardly refusing to install new $filename smaller than $minsize bytes.");
    return 0;
  }

  $class->debug (1, "Replacing $filename\n");

  lstat ($filename);
  if (-d _) {
    $class->debug (1, "rm -fr $filename\n");
    system ('rm', '-fr', $filename);
  }

  my ($dir, $base) = ($filename =~ /^(.*)\/([^\/]+)$/);
  eval { ($fh, $newname) = mkstempt( "${base}XXXXXX", $dir ); };
  if (!defined ($fh) || !defined ($newname)) {
    $class->err ("Failed to create new file $filename!\n", );
    return 0;
  }
  if ($@) {
    $class->err ("%s", $@);
    return 0;
  }
  print $fh $content;
  close $fh;
  # Check it before replacing
  $fh = new FileHandle "$dir/$newname", 'r';
  sysread ($fh, $oldcontent, length ($content));
  if ($oldcontent ne $content) {
    $class->err ("Failed to write $dir/$newname (this is bad).\n");
    return 0;
  }

  # Make the backup
  if ($makebackup) {
    my $backupname = $filename . '~';
    if (-e $backupname) {
      $class->debug (1, "rm -fr $backupname\n");
      system ('rm', '-fr', $backupname);
    }
    if (-e $filename) {
      $class->debug (1, "ln $filename $backupname\n");
      link ($filename, $backupname);
    }
  }
  $class->check_uid_gid_mode ("$dir/$newname", $uid, $gid, $mode);
  $class->debug (1, "mv $dir/$newname $filename\n");
  rename "$dir/$newname", $filename;

  return 1;
}

# Returns the number of changes made (0 == all fine)
sub check_uid_gid_mode {
  my $class = shift;
  my $filename = shift;
  my $uid = shift;
  my $gid = shift;
  my $mode = shift;

  my $changes = 0;

  my ($cmode, $cuid, $cgid) = (CORE::stat $filename)[2,4,5];
  defined $cmode or return 0;

  # Convert uid/gid to numeric if needed
  $uid = (getpwnam $uid)[2] if (defined ($uid) && $uid !~ /^\d+$/);
  $gid = (getgrnam $gid)[2] if (defined ($gid) && $gid !~ /^\d+$/);


  # Being efficient is a pain
  if (defined $uid) {
    if (defined $gid) {
      if ($uid != $cuid || $gid != $cgid) {
	$class->debug (1, "chown $uid.$gid $filename\n");
	$changes += chown $uid, $gid, $filename;
      }
    } else {
      if ($uid != $cuid) {
	$class->debug (1, "chown $uid $filename\n");
	$changes += chown $uid, -1, $filename;
      }
    }
  } elsif (defined $gid) {
    if ($gid != $cgid) {
      $class->debug (1, "chgrp $gid $filename\n");
      $changes += chown -1, $gid, $filename;
    }
  }

  if (defined $mode) {
    if ($mode != ($cmode & 07777)) {
      $class->debug(1, "chmod %o $filename\n", $mode);
      $changes += chmod $mode, $filename;
    }
  }

  $changes;
}

###############################################################################
# Verify that the symlink points to the desired target
# What's this error mean?
#
#
# ln /foo/8069CF0D /foo/8069CF0D~
# ln: `/foo/8069CF0D': warning: making a hard link to a symbolic link is not portable
# ln: creating hard link `/foo/8069CF0D~' to `/foo/8069CF0D': Is a directory
#
# I guess we can neither make backups nor mv the new link into place

sub check_and_replace_link {
  my $class = shift;
  my $fname = shift;
  my $content = shift;

  my $filename = (defined ($::opts{root}) ? $::opts{root} : '') . $fname;
  my $donothing = $class->getoption ('donothing');
  my $would = $donothing ? 'Would ' : '';

  lstat ($filename);
  if (-l _) {
    my $linkval = readlink ($filename);
    defined ($linkval) && ($linkval eq $content) and return 0;
  }

  if (-e _) {
    $class->debug (1, "${would}rm -fr $filename\n");
    $donothing or system ('rm', '-fr', $filename);
  }

  $class->debug (1, "${would}ln -s $content $filename\n");
  $donothing or symlink ($content, $filename);
  return 1;
}

###############################################################################
# Read the XML for a given host.

sub readhost {
  my $section = shift;
  my $what = shift;
  my $args = { @_ };

  my $include_tree = {};
  my ($hostname);

  if (defined $args->{name}) {
    # Try loading the name they gave
    $section->include ($what, $include_tree, -1, {}, $args->{name})
      and return $include_tree;

    # gethostbyname and try again.
    ($hostname) = gethostbyname ($args->{name});
    if (defined ($hostname) && ($hostname ne $args->{name})) {
      $section->include ($what, $include_tree, -1, {}, $hostname)
	and return $include_tree;
    }

    # Otherwise fail
    return undef;
  }

  if ($args->{me}) {
    # Try 'me'
    $hostname = hostname;
    $section->include ($what, $include_tree, -1, {}, $hostname)
      and return $include_tree;

    # gethostbyname and try again.
    ($hostname) = gethostbyname ($hostname);
    if (defined $hostname) {
      $section->include ($what, $include_tree, -1, {}, $hostname)
	and return $include_tree;
    }
  }

  if ($args->{trydefault}) {
    # Last ditch
    $section->include ($what, $include_tree, -1, {}, 'default')
      and return $include_tree;

  }
  # Otherwise fail
  return undef;
}

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

# Some utility functions follow

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

# Set the mode of a file.  Optionally pass the current mode of the file.

sub setfilemode {
  my $self = shift;
  my $dest = shift;
  my $newmode = shift;
  my $currentmode = shift;

  if (!defined $currentmode) {
    my $dst = lstat($dest);
    defined ($dst) and $currentmode = $dst->mode;
  }
  defined ($currentmode) or return 0;
  defined ($newmode) or return 0;
  ($newmode & 07777) == ($currentmode & 07777) and return 0;
  $self->debug (1, "chmod %lo %s\n", $newmode, $dest);
  if (!$self->getoption ('donothing')) {
    chmod (0+$newmode, $dest) or $self->err ("ERROR: chmod %s failed (%s).\n", $dest, $!);
  }
  return 1;
}


# Set the uid of a file.  Optionally pass the current uid.

sub setfileuid {
  my $self = shift;
  my $dest = shift;
  my $newuid = shift;
  my $currentuid = shift;

  if (!defined $currentuid) {
    my $dst = lstat($dest);
    defined ($dst) and $currentuid = $dst->uid;
  }
  $currentuid = $self->name2uid ($currentuid);
  $newuid = $self->name2uid ($newuid);
  if (!defined ($newuid) || !defined ($currentuid)) {
    print STDERR "Ack!  Missing uid on $dest!\n";
    return 0;
  }
  $newuid == $currentuid and return 0;
  $self->debug (1, "chown %d %s\n", $newuid, $dest);
  if (!$self->getoption ('donothing')) {
    chown ($newuid, -1, $dest) or $self->err ("ERROR: chown %s failed (%s).\n", $dest, $!);
  }
  return 1;
}

sub setfilegid {
  my $self = shift;
  my $dest = shift;
  my $newgid = shift;
  my $currentgid = shift;

  if (!defined $currentgid) {
    my $dst = lstat($dest);
    defined ($dst) and $currentgid = $dst->gid;
  }
  $currentgid = $self->name2gid ($currentgid);
  $newgid = $self->name2gid ($newgid);
  if (!defined ($newgid) || !defined ($currentgid)) {
    print STDERR "Ack!  Missing gid on $dest!\n";
    return 0;
  }
  $newgid == $currentgid and return 0;
  $self->debug (1, "chgrp %d %s\n", $newgid, $dest);
  if (!$self->getoption ('donothing')) {
    chown (-1, $newgid, $dest) or $self->err ("ERROR: chgrp %s failed (%s).\n", $dest, $!);
  }
  return 1;
}

sub setfilemtime {
  my $self = shift;
  my $dest = shift;
  my $newmtime = shift;
  my $currentmtime = shift;

  if (!defined $currentmtime) {
    my $dst = lstat($dest);
    defined ($dst) and $currentmtime = $dst->mtime;
  }
  $newmtime == $currentmtime and return 0;
  $self->debug (1, "utime mtime=%s %s\n", ctime($newmtime), $dest);
  if (!$self->getoption ('donothing')) {
    utime ($newmtime, $newmtime, $dest) or $self->err ("ERROR: utime %s failed (%s).\n", $dest, $!);
  }
  return 1;
}

###############################################################################
# Remove a file
sub remove_file {
  my $class = shift;
  my $fname = shift;

  my $filename = (defined ($::opts{root}) ? $::opts{root} : '') . $fname;
  lstat $filename;
  (-e _) or return 0;

  $class->debug (1, "rm %s\n", $filename);
  $class->getoption ('donothing') or return unlink $filename;
  return 0;
}


###############################################################################
# Convert an alphanumeric user name to a numeric uid

sub name2uid {
  my $self = shift;
  my $luser = shift;

  return undef unless defined $luser;
  ($luser =~ /^\d+$/) and return $luser;
  return scalar (getpwnam ($luser));
}


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

sub name2gid {
  my $self = shift;
  my $group = shift;

  return undef unless defined $group;
  ($group =~ /^\d+$/) and return $group;
  return scalar (getgrnam ($group));
}

###############################################################################
# Prompt for a yes/no answer and return the answer

sub yesno {
  my $self = shift;
  my $default = shift;
  my $prompt = shift;

  print $prompt . ($default ? " (Y/n)? " : " (N/y)? ");

  do {
    $_ = <STDIN>;
    chomp;
    length or return $default;
    /^\s*[1YyTt]/ and return 1;
    /^\s*[0NnFf]/ and return 0;
    print STDERR "Please answer one of yes, true, 1, no, false, 0, or [Enter]\n";
  } while (1);

  # Not reached
  return undef;
}

###############################################################################
# Do a system command

sub do_system {
  my $self = shift;
  my @argv = @_;

  $self->debug(0, join (' ', @argv) . "\n");
  $self->getoption('donothing') and return 0;
  return system (@argv) >> 8;
}

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

1;
