# -*-perl-*-

# $Id: Files.plm,v 1.17 2006/02/09 22:32:07 thomas Exp $

# This perl module implements the files component of the host configuration
# environment.

# $Log: Files.plm,v $
# Revision 1.17  2006/02/09 22:32:07  thomas
# Oops.  Add content="inline" where appropriate
#
# Revision 1.16  2006/02/07 15:07:57  thomas
# Consistent handling of text component.
#
# Revision 1.15  2006/02/01 19:09:54  thomas
# handle content=inline
# print content of content=inline nodes
#
# Revision 1.14  2005/01/10 21:55:57  thomas
# Copy files (more) securely
#
# Revision 1.13  2004/12/07 19:49:19  thomas
# apply: re-stat $dest after deleting it
#
# Revision 1.12  2004/05/05 15:28:12  thomas
# Fix symbolic link processing
#
# Revision 1.11  2004/04/13 21:11:48  thomas
# Set mode _after_ setting uid/gid
#
# Revision 1.10  2004/04/08 21:28:49  thomas
# Catch-up
#
# Revision 1.8  2004/03/22 17:40:07  thomas
# Fix generate function (broken for some usages
#
# Revision 1.7  2004/03/05 15:12:27  thomas
# cconf->what
#
# Revision 1.6  2004/02/10 16:40:11  thomas
# pre-0.1.5 fork
#
# Revision 1.5  2004/01/22 21:02:04  thomas
# [CSL #172151]
#
# Revision 1.4  2004/01/21 21:42:52  thomas
# commit before branch to 0.1.4
#
# Revision 1.3  2004/01/13 16:48:31  thomas
# catch-up 1/13/04
#
# Revision 1.2  2003/12/15 16:28:35  thomas
# check-in for 0.1.1
#
# Revision 1.1.1.1  2003/12/02 14:47:34  thomas
# Initial version before export to 0.1.1
#

package  What::Node::Files;

use strict;
use FileHandle;
use DirHandle;
use Data::Dumper;
use Digest::MD5;
use File::stat;
use File::MkTemp;
use Time::localtime;

use base qw(What::Node);

# Need to specify the options (with default values) that
# can be specified for the 'new' method.
our %opts = (
	     create => 1,
	     getatime => 0,
	     getMD5sum => 1,
	     getgid => 1,
	     getmode => 1,
	     getmtime => 1,
	     getsize => 1,
	     getuid => 1,
	     keepmodes => 1,
	     merge => 0,
	     numeric_ids => 0,
	     skip_devs => 1,
	     skip_file_modes => 0,
	     skip_sockets => 0,
	     setatime => 0,
	     setgid => 1,
	     setmode => 1,
	     setmtime => 1,
	     setuid => 1,
	     useMD5 => 1,
	    );


# Set the priority for this module in $::
$::module_priority{'Files'} = 40;

###############################################################################
sub collapse {
  my $self = shift;
  my $section = shift;
  my $path = shift;

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

  $attrs = $self->getattrs ($section);
  defined ($attrs->{type}) && $attrs->{type} eq 'symlink' and return;

  if (defined ($attrs->{source}) && $attrs->{source} =~ s\${path}$\\ ) {
    $self->setattr ($section, srcdir => $attrs->{source});
    $self->un_link ( undef, 'source');
  }
  defined ($attrs->{type}) or return;
  $attrs->{type} eq 'dir' or return;
  $children = $self->getchildren ($section);
  $path eq '/' and $path = '';
  foreach $child (keys %$children) {
    $children->{$child}->collapse ($section, "$path/$child");
  }
}

###############################################################################
#
# This is the version of the write method that outputs everything in a
# flat structure (i.e., the names contain complete paths, and there is no
# nesting of xml entity types

sub write {
  my $self  = shift;   # Class root
  my $section = shift; # Section object
  my $what = shift;   # What object
  my $sname  = shift;  # Section name
  my $cname = shift;   # Class name ('Files')
  my $fh    = shift;   # file handle

  # Try to turn source tags back into srcdir tags
  my $opts = $self->getoptions;
  $opts->{mksrcdir} and  $self->collapse ($section, '/');

  my $inodes = [];
  $self->write_r ($section, $fh, $inodes, '/Files');
  return 1;
}

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

  my ($inode, $attrs, $type, $children, $child);
  my ($tag, $ttag, $trigger);
  my $subcontent = 0;

  $inode = $self->inode;
  if (defined $inodes->[$inode]) {
    print $fh "  <hardlink path=\"$name\" source=\"$inodes->[$inode]\" />\n";
    return 1;
  }
  $inodes->[$inode] = $name;


  $attrs = $self->getattrs ($section);
  $children = $self->getchildren ($section);

  # Don't print a node if it doesn't have attributes, but _do_
  # descend through its children
  if (keys %$attrs) {

    if (defined $attrs->{type}) {
      $type = $attrs->{type};
    } elsif (keys %$children) {
      $type = 'dir';
    } else {
      return 1;
    }

    print $fh "  <node path=\"$name\" type=\"$type\" ";

    # Everything except links can have uid/gid/mode
    if ($type ne 'symlink' && $type ne 'delete') {
      foreach $tag ('uid', 'gid') {
	defined ($attrs->{$tag}) and print $fh "$tag=\"$attrs->{$tag}\" ";
      }
      defined ($attrs->{mode}) and print $fh "mode=\"$attrs->{mode}\" ";
    }

    # Only devices can have major and/or minor numbers
    if ($type eq 'block' || $type eq 'char') {
      foreach $tag ('major', 'minor') {
	defined ($attrs->{$tag}) and print $fh "$tag=\"$attrs->{$tag}\" ";
      }
    }

    # Lots of tags are specific to regular files
    if ($type eq 'file' || $type eq 'create' ) {
      foreach $tag ('source', 'srcdir', 'md5sum', 'atime', 'mtime', 'size',) {
	defined ($attrs->{$tag}) and print $fh "$tag=\"$attrs->{$tag}\" ";
      }
    }

    # And the cleandir tags is only applicable to directories
    if ($type eq 'dir') {
      defined ($attrs->{cleandir}) and print $fh "cleandir=\"$attrs->{cleandir}\" ";
    }

    # Print the source for symlinks
    if ($type eq 'symlink' &&
	exists ($attrs->{source}) &&
	defined ($attrs->{source})) {
      print $fh "source=\"$attrs->{source}\" ";
    }

    if (defined ($attrs->{content}) && $attrs->{content} eq "inline") {
      print $fh "content=\"inline\" >\n";
      $subcontent = 1;
      my $text = $self->grocktext ($section);
      print $fh $text;
    }

    # Anything can have a trigger
    if (defined ($attrs->{trigger}) &&
	ref($attrs->{trigger}) eq 'HASH') {
      if (!$subcontent) {
	print $fh ">\n";
	$subcontent = 1;
      }
      $self->write_triggers ($attrs->{trigger}, $fh);
      # print $fh "/>\n";
    }

    if ($subcontent) {
      print $fh "  </node>\n";
    } else {
      print $fh "/>\n";
    }

  } else {
    # Hack to get descent into child nodes to go
    $type = 'dir';
  }

  if ($type eq 'dir') {
    foreach $child (sort keys %$children) {
      $children->{$child}->write_r ($section, $fh, $inodes, "$name/$child");
    }
  }
  return 1;
}


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

# These next routines deal with generate method -
#   creating xml directly from a directory tree.

# If start_dir is defined, create each entry as it exists from root.
# Then call traverse with the start_dir entry.

sub generate {
  my ($self, $section, $what, $start_dir) = @_;

  my (@dirs, $dir, $last, $tree, $node, $newnode, $rootnode);
  my $root = defined ($::opts{root}) ? $::opts{root} : '';
  my $path = $root;
  $path =~ s;/$;;;

  if (defined ($start_dir)) {
    ($start_dir =~ /^\//) or $start_dir = "/$start_dir";
  } else {
    $start_dir='';
  }

  @dirs = $section->split_name ($start_dir);
  $last = pop @dirs;

  my $inodes = {};
  if (defined $last) {
    $rootnode = $self->mknod ($section, (length($path)?$path:'/'), $root);
    $node = $rootnode;
    foreach $dir (@dirs) {
      length ($dir) or next;
      $path = "$path/$dir";
      defined ($newnode = $self->mknod ($section, $path, $root)) or return undef;
      $node->addchildren ($dir => $newnode);
      $node = $node->getchildren ($section, child => $dir);
    }
    defined ($newnode = $self->traverse ($section, $what, $root, $start_dir, $inodes)) or return undef;
    $node->addchildren ($last => $newnode);
  } else {
    $rootnode = $self->traverse ($section, $what, $root, '', $inodes);
  }
  # Copy node into $self
  $self->setattrs ($section, $rootnode->getattrs ($section));
  $self->addchildren (%{$rootnode->getchildren ($section)});
  undef $node;
  return $self;
}


###############################################################################
# Traverse a directory -- Do it this way so that '/' also gets into
# the output XML.

sub traverse {
  my $self    = shift;
  my $section = shift;
  my $what   = shift;
  my $root    = shift;
  my $current = shift;
  my $inodes  = shift;

  my $file = "$root$current";

  # Hack for root
  my $nodename = length ($current) ? $current : '/';

  my $node = $self->mknod ($section, $file, $root);
  defined ($node) or return undef;
  my $attrs = $node->getattrs ($section);
  # skip devices if we're supposed to
  (($attrs->{type} eq 'block') || ($attrs->{type} eq 'char')) &&
    $self->getoptions ('skip_devs') and return undef;
  ($attrs->{type} eq 'fifo') && $self->getoptions ('skip_fifos')
    and return undef;
  ($attrs->{type} eq 'socket') && $self->getoptions ('skip_sockets')
    and return undef;

  # Remove owner, group, mode from files if we're supposed to
  if ($self->getoptions ('skip_file_modes') && $attrs->{type} eq 'file') {
    delete $attrs->{uid};
    delete $attrs->{gid};
    delete $attrs->{mode};
    $node->un_link (undef, 'uid', 'gid', 'mode');
  }
  if (defined $inodes->{$attrs->{inode}}) {
    if ($attrs->{type} eq 'dir') {
      $self->err ("Skipping hard link %s to directory(!)\n", $file);
      return undef;
    }
    # $self->debug(3, "%s is a hardlink...\n", $file);
    return ($inodes->{$attrs->{inode}});
  }
  $inodes->{$attrs->{inode}} = $node;

  # Recurse directories
  $attrs->{type} eq 'dir' or return $node;

  my $dh = new DirHandle $file;
  if (!defined $dh) {
    $self->err ("Can't start directory scan on %s\n", $file);
    return;
  }
  my $de;
  while (defined($de = $dh->read)) {
    ($de =~ /^\.\.?$/) and next;
    my $child = $self->traverse ($section, $what, $root, "$current/$de", $inodes);
    defined ($child) and $node->addchildren ($de => $child);
  }
  undef $dh;
  return $node;
}

###############################################################################
# Stat a file and make a node from the information

sub mknod {

  my $self = shift;
  my $section = shift;
  my $file = shift;
  my $srcdir = shift;

  my $attrs = {};
  my $opts = $self->getoptions;

  length ($srcdir) or $srcdir = '/';
  my ($fh, $major_dev, $minor_dev, $type);
  my $st = lstat ($file);
  if (!defined ($st)) {
    $self->err ("Failed to stat %s!\n", $file);
    return undef;
  }
  my $mode = sprintf "%lo", $st->mode & 07777;

  if (-f _) {
    $attrs->{type} = 'file';
    $opts->{getatime} and $attrs->{atime} = $st->atime;
    $opts->{getmtime} and $attrs->{mtime} = $st->mtime;
    $opts->{getsize}  and $attrs->{size}  = $st->size;
    $attrs->{source} = $file;
    if ($opts->{getMD5sum}) {
      $attrs->{md5sum} = $self->getmd5 ($file);
    }

  } elsif (-d _) {
    $attrs->{type} = 'dir';

  } elsif (-l _) {
    $attrs->{type} = 'symlink';
    $attrs->{source} = readlink ($file);

  } elsif (-b _ || -c _) {
    $type = 'block';
    (-c _) and $type = 'char';
    $attrs->{type} = $type;
    $attrs->{major} = getmajor ($st->rdev);
    $attrs->{minor} = getminor ($st->rdev);

  } elsif (-S _) {
    $attrs->{type} = 'socket';

  } elsif (-p _) {
    $attrs->{type} = 'fifo';

  } else {
    die "Unknown file type for $file!\n";
  }

  if ($attrs->{type} ne 'symlink') {
    $opts->{getuid}  and $attrs->{uid}  = $st->uid;
    $opts->{getgid}  and $attrs->{gid}  = $st->gid;
    $opts->{getmode} and $attrs->{mode} = $mode;
  }
  $attrs->{inode} = $st->dev . ":" . $st->ino;
  my $node = $self->new ();
  $node->setattrs ($section, $attrs);
  return $node;
}


###############################################################################
# Return the major and minor numbers for the device.  There doesn't seem
# to be a system-independent way of getting this...

sub getmajor {
  my $rdev = shift;

  # some systems use longwords - detect
  if ($rdev & 0xfff00000) {
    return ($rdev >> 20) & 0x00000fff;
  } else {
    return ($rdev >> 8) & 0x000000ff;
  }
}

sub getminor {
  my $rdev = shift;

  # some systems use longwords - detect
  if ($rdev & 0xfff00000) {
    return ($rdev) & 0x000fffff;
  } else {
    return ($rdev) & 0x000000ff;
  }
}


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

# Apply the passed configuration, optionally at root $root.

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

  my $inodes = [];
  my $root = defined ($::opts{root}) ? $::opts{root} : '/';
  $root =~ s:/+$::;
  my $changes = $class->apply_more ($section, $what, $root, '', $inodes);
  return $changes;
}


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

sub apply_more {
  my $self   = shift;
  my $section = shift;
  my $what  = shift;
  my $root   = shift;
  my $path   = shift;
  my $inodes = shift;

  my $dest = "$root$path";
  ($dest eq '') and $dest = '/';
  $self->debug (4, "apply_more: dest=%s\n", $dest);
  my $st = lstat($dest);
  my ($dh, $de, @dels, $link, $dir, $tmpfile, $major, $minor, $source, $sst, $type, $sourcefile, $fh);
  my $changes = 0;
  my $inode = $self->inode;
  # check for hard links...
  if (defined $inodes->[$inode]) {
    return $self->buildlink ($inodes->[$inode],
			     $dest,
			     $self->getoptions ('convert_hard_links'),
			     0);
  }

  # Define the entry for this node.
  $inodes->[$inode] = $dest;

  my $attrs = $self->getattrs ($section);
  my $children = $self->getchildren ($section);
  if (!defined $attrs->{type}) {
    # Infer....
    %$children or return 0;
    $attrs->{type} = 'dir';
  }

  # [CSL #171931]
  if ((keys %$children) && ($attrs->{type} ne 'dir')) {
    $self->err ("Node %s is not a directory but has children!\n", $dest);
    $self->err ("  (This is usually caused by bad XML)\n");
  }

  $type = $attrs->{type};
  if ($type eq 'dir') {
    if (-e _ && !-d _) {
      $self->safe_delete ($dest);
      $changes++;
      # Re-stat the destination (it just went away)
      $st = lstat($dest);
    }
    if (!-e _) {
      $self->debug (1, "mkdir %s\n", $dest);
      $self->getoption ('donothing') or mkdir ($dest);
      $changes++;
    }
    $changes += $self->setfileattrs ($section, $path, $dest);

    # Check for delete requirement
    if ($attrs->{cleandir}) {
      if (defined ($dh = new DirHandle ($dest))) {
	while (defined ($de = $dh->read)) {
	  ($de =~ /^\.\.?$/) and next;
	  if (!defined ($children->{$de})) {
	    $self->safe_delete ("$root$path/$de");
	  }
	}
      }
    }

    # Now process the directory's contents
    foreach $de ( sort keys %$children) {
      $changes += $children->{$de}->apply_more ($section, $what, $root, "$path/$de", $inodes);
    }


  } elsif ($type eq 'file') {
    (-d _) and $self->safe_delete ($dest);
    if ($self->check_file_contents ($section, $path, $dest)) {
      $changes++;
      $tmpfile = $self->gettemp ($dest);
      $self->copy_file ($section, $path, $tmpfile) or return 1;
      $changes += $self->setfileattrs ($section, $path, $tmpfile);
      $self->debug (1, "mv %s %s\n", $tmpfile, $dest);
      $self->getoption('donothing') or rename ($tmpfile, $dest);
    } else {
      $changes += $self->setfileattrs ($section, $path, $dest);
    }


  } elsif ($type eq 'create') {
    if (-d _) {
      $self->safe_delete ($dest);
      # Re-stat $dest (it just went away)
      $st = lstat($dest);
    }
    if (! -f _) {
      $sourcefile = $self->getsource ($section, $path);
      $changes++;
      $tmpfile = $self->gettemp ($dest);
      if (defined $sourcefile) {
	# Copy the specified source
	$self->copy_file ($section, $path, $tmpfile) or return 1;
      } else {
	# Just touch an empty file
	$self->debug (1, "touch %s\n", $tmpfile);
	if (!$self->getoption ('donothing')) {
	  $fh = new FileHandle $tmpfile, 'w';
	  undef $fh;
	}
      }
      $changes += $self->setfileattrs ($section, $path, $tmpfile);
      $self->debug (1, "mv %s %s\n", $tmpfile, $dest);
      $self->getoption ('donothing') or rename ($tmpfile, $dest);
    }

  } elsif ($type eq 'setattrs') {
    $changes += $self->setfileattrs ($section, $path, $dest);

  } elsif ($type eq 'symlink') {
    if (-d _)  {
      $changes = $self->safe_delete ($dest);
      # Re-stat $dest (it just went away)
      $st = lstat($dest);
    }
    if (defined $attrs->{source}) {
      my $source = $section->substitute_vars ($attrs->{source});
      if ((-l _) && (readlink ($dest) eq $source)) {
	;
      } elsif (! -e _)  {
	$changes++;
	$self->debug (1, "ln -s %s %s\n", $source, $dest);
	$self->getoption ('donothing') or symlink ($source, $dest);
      } else {
	$changes++;
	$tmpfile = $self->gettemp ($dest);
	$self->debug (1, "ln -s %s %s\n", $source, $tmpfile);
	$self->getoption ('donothing') or symlink ($source, $tmpfile);
	$self->debug (1, "mv %s %s\n", $tmpfile, $dest);
	$self->getoption ('donothing') or rename ($tmpfile, $dest);
      }
    } else {
      $self->error ("No source specified in symlink for %s!\n", $dest);
    }


  } elsif ($type eq 'block' ) {
    if (-d _) {
      $changes += $self->safe_delete ($dest);
      $st = lstat ($dest);  # Refresh
    }
    if ((-b _) &&
	getmajor ($st->rdev) == $attrs->{major} &&
	getminor ($st->rdev) == $attrs->{minor}) {
      $changes += $self->setfileattrs ($section, $path, $dest);
    } else {
      $changes++;
      $tmpfile = $self->gettemp ($dest);
      $self->debug (1, "mknod %s b %d %d\n", $tmpfile, $attrs->{major}, $attrs->{minor});
      $self->getoption ('donothing') or system ('mknod', $tmpfile, 'b', $attrs->{major}, $attrs->{minor});
      $changes += $self->setfileattrs ($section, $path, $tmpfile);
      $self->debug (1, "mv %s %s\n", $tmpfile, $dest);
      $self->getoption ('donothing') or rename ($tmpfile, $dest);
    }


  } elsif ($type eq 'char') {
    if (-d _) {
      $changes += $self->safe_delete ($dest);
      $st = lstat ($dest);  # Refresh
    }
    if ((-c _) &&
	getmajor ($st->rdev) == $attrs->{major} &&
	getminor ($st->rdev) == $attrs->{minor}) {
      $changes = $self->setfileattrs ($section, $path, $dest);
    } else {
      $changes++;
      $tmpfile = $self->gettemp ($dest);
      $self->debug (1, "mknod %s c %d %d\n", $tmpfile, $attrs->{major}, $attrs->{minor});
      $self->getoption ('donothing') or system ('mknod', $tmpfile, 'c', $attrs->{major}, $attrs->{minor});
      $changes += $self->setfileattrs ($section, $path, $tmpfile);
      $self->debug (1, "mv %s %s\n", $tmpfile, $dest);
      $self->getoption ('donothing') or rename ($tmpfile, $dest);
    }


  } elsif ($type eq 'pipe') {
    if (-d _) {
      $changes += $self->safe_delete ($dest);
      $st = lstat ($dest);  # Refresh
    }
    if (-p _) {
      $changes = $self->setfileattrs ($section, $path, $dest);
    } else {
      $changes++;
      $tmpfile = $self->gettemp ($dest);
      $self->debug (1, "mknod %s p\n", $tmpfile);
      $self->getoption ('donothing') or system ('mknod', $tmpfile, 'p');
      $changes += $self->setfileattrs ($section, $path, $tmpfile);
      $self->debug (1, "mv %s %s\n", $tmpfile, $dest);
      $self->getoption ('donothing') or rename ($tmpfile, $dest);
    }


  }  elsif ($type eq 'delete') {
    $changes = $self->safe_delete ($dest);
    return 1;


  } elsif ($type eq 'socket') {
    $self->err ("Ignoring socket %s\n", $dest);

  } else {
    $self->err ("Sorry, don't know about node type %s for node %s/%s.\n", $type, $root, $path);
    return 0;
  }

  $changes && $self->run_triggers ($section, $what, $path);

  return $changes;
}

###############################################################################
# Given a source and destination path for a hardlink, return the eqivalent
# source for a relative symbolic link.

sub convert_hard_link {
  my $self   = shift;
  my $source = shift;
  my $dest   = shift;

  # Convert the absolute reference $source into a relative one, given that
  # both are absolute paths.  Examples:
  #
  # src: /a/b/c
  # dst: /a/b/d
  # result: ln -s c /a/b/d
  #
  # src: /a
  # dst: /b/c/d
  # result: ln -s ../../a /b/c/d
  #
  # src: /a/e/f
  # dst: /b/c/d
  # result: ln -s ../../a/e/f /b/c/d
  #
  # src: /a/e/f
  # dst: /a/c/d
  # result: ln -s ../e/f /a/c/d
  #
  # src: /a/e/f/g
  # dst: /a/c
  # result: ln -s e/f/g /a/c
  #
  # So, we take off whatever part is common between the two, then put
  # as many '..' in front of what's left of the source as there are
  # components of the destination, except for the final component.  Easy...
  #
  my @src = $self->split_name ($source);
  my @dest = $self->split_name ($dest);

  while (@src && @dest && $src[0] eq $dest[0]) {
    shift @src;
    shift @dest;
  }
  while (@dest>1) {
    unshift @src, '..';
    shift @dest;
  }
  return $self->joinDirs (@src);
}


###############################################################################
# Return 1 if the destination is different from $cnode
# This assumes a 'file' node

# Return 0 if $path and $dest are the same
# Return 1 for different, or -1 for errors
sub check_file_contents {
  my $self  = shift;
  my $section = shift;
  my $path = shift;
  my $dest  = shift;

  my ($fh, $dst, $sst, $sourcefile, $source_md5, $dest_md5);
  my $opts = $self->getoptions;
  my $attrs = $self->getattrs ($section);

  $self->debug (4, "check_file_contents:dest=%s\n", $dest);
  $dst = (-e $dest)?lstat($dest):undef;
  defined ($dst) or return -1;
  (-f _) or return 1;

  if ($opts->{useMD5}) {
    if ($attrs->{md5sum}) {
      $source_md5 = $attrs->{md5sum};
    } else {
      # Ick -- calculate it now
      if (defined ($attrs->{content}) && $attrs->{content} eq 'inline') {
	my $text = $self->grocktext ($section);
	return -1 unless defined $text;
	$source_md5 = Digest::MD5->new->add($text)->hexdigest;
      } else {
	$sourcefile = $self->getsource ($section, $path);
	return -1 unless defined $sourcefile;
	return -1 unless defined ($source_md5 = $self->getmd5 ($sourcefile));
      }
    }
    return 1 unless defined ($dest_md5 = $self->getmd5 ($dest));
    return ($dest_md5 ne $source_md5);
  }

  # Or, check mtime and size
  $sourcefile = $self->getsource ($section, $path);
  $self->debug (4, "check_file_contents:sourcefile=%s\n", $sourcefile);
  $sst = lstat ($sourcefile);
  if (!defined $sst) {
    $self->err ("Files::check_file_contents(): Can't stat source file %s for node %s!\n", $sourcefile, $dest);
    return 0;
  }
  return ($dst->size != $sst->size || $dst->mtime != $sst->mtime);
}


# Return the md5 sum for $path
sub getmd5 {
  my $self = shift;
  my $path = shift;

  my $fh = new FileHandle $path, "r";
  if (!defined ($fh)) {
    $self->debug (5, "Files::getmd5(): %s doesn't exist.\n", $path);
    return undef;
  }
  my $dest_md5 = Digest::MD5->new->addfile($fh)->hexdigest;
}


# Return the grocked text from a node, or undef
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";
}


###############################################################################
# Copy the file from $self to $dest

sub copy_file {
  my $self = shift;
  my $section = shift;
  my $path = shift;
  my $dest = shift;

  my $attrs = $self->getattrs ($section);
  if (defined ($attrs->{content}) && $attrs->{content} eq 'inline') {
    # I have the data
    my $text = $self->grocktext ($section);
    if (!defined $text) {
      $self->err ("content=\"inline\" specified for %s but no source data found!\n", $dest);
      return 0;
    }
    $self->debug (1, "create %s\n", $dest);
    $self->getoption ('donothing') and return 1;
    my $dfh = new FileHandle $dest, O_CREAT|O_EXCL|O_WRONLY, 0600;
    if (!defined $dfh) {
      $self->err ("Can't open destination file %s for copy!\n", $dest);
      return 0;
    }
    print $dfh $text;
    return 1;
  }

  my $sourcefile = $self->getsource ($section, $path);
  if (!defined $sourcefile) {
    $self->err ("copy_file: No source file give for %s!\n", $dest);
    return 0;
  }
  $self->debug (1, "cp %s %s\n", $sourcefile, $dest);
  $self->getoption ('donothing') and return 1;

  my $sfh = new FileHandle $sourcefile, "r";
  if (!defined $sfh) {
    $self->err ("Can't open source file %s for copy!\n", $sourcefile);
    return 0;
  }	
  my $dfh = new FileHandle $dest, O_CREAT|O_EXCL|O_WRONLY, 0600;
  if (!defined $dfh) {
    $self->err ("Can't open destination file %s for copy!\n", $dest);
    return 0;
  }
  my ($buf, $count, $written);
  while (($count=sysread ($sfh, $buf, 32*1024))>0) {
    if (($written=syswrite ($dfh, $buf)) != $count) {
       $self->err ("Short write on %s -- requested %d, wrote %d!\n", $dest, $count, $written);
      return 0;
    }
  }
  # All OK
  return 1;
}


###############################################################################
# Get the source for the passed 'file' node

sub getsource {
  my $self  = shift;
  my $section = shift;
  my $path  = shift;

  my $attrs = $self->getattrs ($section);
  defined ($attrs->{srcdir}) and return $section->substitute_vars ($attrs->{srcdir}) . $path;
  return $section->substitute_vars ($attrs->{source});

}


###############################################################################
# Return the path to a temporary file in the same directory as $dest

sub gettemp {
  my $self = shift;
  my $old = shift;

  my ($dir, $base) = ($old =~ /^(.*)\/([^\/]+)$/);
  # mktemp doesn't work if the directory isn't there, which
  # can happen when in donothing mode.
  if ($self->getoption ('donothing')) {
    return ("$dir/$base.XXXXXX");
  }
  my $temp = mktemp ($base . '.XXXXXX', $dir);
  return ("$dir/$temp");
}


###############################################################################
# Verify and/or create a hard link as requested.  $symlink means:
#
#   0 -> Create a hard link, unless $self->{opts}->{convert_hard_links} is
#        set, in which case create a relative symbolic link
#   1 -> Build a ver batim symbolic link

sub buildlink {
  my $self = shift;
  my $dest  = shift;
  my $source  = shift;
  my $symlink = shift;
  my $relative = shift;

  my ($dst, $sst, $tmpfile, $linkval);
  # Short circuit the ok check for symbolic links
  # As a side effect, convert $source for relative symbolic links
  if ($symlink || $self->{opts}->{convert_hard_links}) {
    $self->{opts}->{convert_hard_links} and
      $source = $self->convert_hard_link ($source, $dest);
    $linkval = readlink ($dest);
    (defined ($linkval) && ($linkval eq $source)) and return 0;
  }

  # Something isn't right.  Stat stuff, and delete $dest if it's a dir.
  $self->debug (4, "buildlink: dest=%s\n", $dest);
  $dst = lstat ($dest);
  (-d _) and $self->safe_delete ($dest);

  # From here on out, branch on link type.
  # Either $dest doesn't exist or it's a non-directory.
  if ($symlink || $self->{opts}->{convert_hard_links}) {
    # Symbolic link
    if (defined ($dst)) {
      $tmpfile = $self->gettemp ($dest);
      $self->debug (1, "ln -s %s %s\n", $source, $tmpfile);
      $self->getoption ('donothing') or symlink ($source, $tmpfile);
      $self->debug (1, "mv %s %s\n", $tmpfile, $dest);
      $self->getoption ('donothing') or rename ($tmpfile, $dest);
    } else {
      $self->debug (1, "ln -s %s %s\n", $source, $dest);
      $self->getoption ('donothing') or symlink ($source, $dest);
    }
    return 1;
  }

  # Hard link
  $self->debug (4, "buildlink: source=%s\n", $source);
  $sst = lstat ($source);
  if (!defined $sst) {
    $self->err ("Can't stat source %s for hard link creation\n", $source);
    return 0;
  }
  # Return if $sst is the same as $dst.
  if (defined ($dst)) {
    ($sst->dev == $dst->dev && $sst->ino == $dst->ino) and return 0;
    $tmpfile = $self->gettemp ($dest);
    $self->debug (1, "ln $source %s\n", $tmpfile);
    $self->getoption ('donothing') or link $source, $tmpfile;
    $self->debug (1, "mv %s %s\n", $tmpfile, $dest);
    $self->getoption ('donothing') or rename ($tmpfile, $dest);
  } else {
    $self->debug (1, "ln %s %s\n", $source, $dest);
    $self->getoption ('donothing') or link $source, $dest;
  }
  return 1;
}


###############################################################################
# Recursively delete the tree at $path.

sub safe_delete {
  my $self = shift;
  my $path = shift;

  my ($st, $dh, $de);
  my ($deleted) = 0;

  $st = lstat ($path);
  defined ($st) or return 0;

  if (-d _) {
    $dh = new DirHandle $path;
    defined ($dh) or return 0;
    while (defined ($de=$dh->read)) {
      $de =~ /^\.\.?$/ and next;
      $deleted += $self->safe_delete ("$path/$de");
    }
    $self->debug (1, "rmdir %s\n", $path);
    $self->getoption ('donothing') or return rmdir $path;
    $deleted++;
  } else {
    $self->debug (1, "rm %s\n", $path);
    $self->getoption ('donothing') or return unlink $path;
    $deleted++;
  }
  return $deleted;
}

###############################################################################
# Set the mode, uid, and gid of $path.  If an attribute isn't listed in
# $cnode, and $sourcefile can be statted, copy the attribute from $sourcefile.
# Track if we've stat()ed the source file, and only do it (or try it) once.


sub setfileattrs {
  my $self = shift;
  my $section = shift;
  my $path = shift;
  my $dest = shift;

  $self->debug (4, "setfileattrs: dest=%s\n", $dest);

  my ($uid, $gid, $mode, $mtime);
  my $changes = 0;
  my $attrs = $self->getattrs ($section);
  my $opts = $self->getoptions;

  my $sourcefile = $self->getsource ($section, $path);
  my ($triedstat, $sst) = (0, undef);
  defined ($sourcefile) or $triedstat = 1;

  my $dst = lstat($dest);
  if (!defined $dst) {
    $self->err ("ERROR: Can't set attributes on non-existent %s!\n", $dest);
    return 0;
  }

  # Set the uid
  if ($opts->{setuid}) {
    defined ($attrs->{uid}) and $uid = $attrs->{uid};
    if (!defined $uid) {
      if (!defined ($sst) && !$triedstat) {
	$triedstat = 1;
	(-e $sourcefile) and $sst = stat ($sourcefile);
      }
      defined ($sst) and $uid = $sst->uid;
    }
    defined ($uid) and $changes += $self->setfileuid ($dest, $uid, $dst->uid);
  }

  # Set the gid
  if ($opts->{setgid}) {
    defined ($attrs->{gid}) and $gid = $attrs->{gid};
    if (!defined $gid) {
      if (!defined ($sst) && !$triedstat) {
	$triedstat = 1;
	(-e $sourcefile) and $sst = stat ($sourcefile);
      }
      defined ($sst) and $gid = $sst->gid;
    }
    defined ($gid) and $changes += $self->setfilegid ($dest, $gid, $dst->gid);
  }

  # Set the mode.
  if ($opts->{setmode}) {
    defined ($attrs->{mode}) and $mode = oct ($attrs->{mode});
    if (!defined $mode) {
      if (!defined ($sst) && !$triedstat) {
	$triedstat = 1;
	(-e $sourcefile) and $sst = stat ($sourcefile);
      }
      defined ($sst) and $mode = $sst->mode;
    }
    defined ($mode) and $changes += $self->setfilemode ($dest, $mode, $dst->mode);
  }

  ($attrs->{type} eq 'file' || $attrs->{type} eq 'create') or return $changes;

  # Set the mtime
  if ($opts->{setmtime}) {
    defined ($attrs->{mtime}) and $mtime = $attrs->{mtime};
    if (!defined $mtime) {
      if (!defined ($sst) && !$triedstat) {
	$triedstat = 1;
	(-e $sourcefile) and $sst = stat ($sourcefile);
      }
      defined ($sst) and $mtime = $sst->mtime;
    }
    defined ($mtime) and $changes += $self->setfilemtime ($dest, $mtime, $dst->mtime);
  }
}

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

=head1 NAME

What::Mod::Files - what Files object type

=head1 DESCRIPTION

This what configuration object controls the installation and removal
of specific files on the target system.

=head1 GENERATE

To generate a what description of a directory tree, use the what
B<generate> command:

C<what [--root I<root_dir>] generate Files [I<start_dir>]>

Where I<root_dir> is the absolute root of the directory tree that will be
generated, and the optional I<start_dir> is the place where you would
like parsing to begin.

=head2 EXAMPLES

C<what --root /s/krb5/@sys generate Files>

Dump the files in the tree F</s/krb5/@sys>.  Note that /s/krb5/@sys
B<will not> appear in the output emmitted.

C<what generate /dev>

Dump the files in the /dev directory, but include the /dev prefix on
the output.

=head1 SEE ALSO

What::Command::generate

=head1 XML FORMAT

The following XML sample should show all the common types of data that
may be included in a <Files> what section.  In all cases, uids can be
either numeric or symbolic.  Modes are interpreted by the perl oct()
function.


<what>
 <Files>

  A directory.

  <node type="dir" path="/Files/usr/csl/lib" cleandir="0" uid="0" gid="0" mode="755" />

  A regular file, with a named source.

  <node type="file" path="/Files/usr/csl/bin/console" uid="root" gid="0" mode="755" source="/s/uwconserv/bin/console" />

  A regular file, referencing only the root of the source directory.

  <node type="file" path="/Files/etc/mail.rc" uid="0" gid="0" mode="644" srcdir="/afs/cs/i386_rh9/what/site" />

  A regular file with multiple triggers.

  <node type="file" path="/Files/var/adm/crontabs/local/root" uid="0" gid="0" mode="644" source="/p/lab/what/crontab-root/roo.cs.wisc.edu" >
    <trigger name="File_changed_mail" to="lab@cs.wisc.edu" subject="new root crontab" />
    <trigger name="Reload" init="crond" />
  </node>

  Create a file only if it doesn't exist.  This creates an empty file.

  <node type="create" path="/Files/var/log/foolog" uid="root" gid="root" mode="0600" />

  Create a fileonly if it doesn't exist, copying some initial content.

  <node type="create" path="/Files/etc/adjtime" uid="root" gid="root" mode="0644" source="/s/lab/default/etc/adjtime" />

  Adjust the attributes of a file that was created outside of 'what'

  <node type="setattrs" path="/Files/usr/sbin/tethereal" uid="0" mode="04755" />

  A symbolic link.  This can be relative or absolute.

  <node type="symlink" path="/Files/usr/csl/lib/libkrb5.so" source="libkrb5.so.3" />

  A hard link.  Cant think up a real example for this...

  <node type="hardlink" path="/Files/dev/foo" source="/dev/bar" />

  A block device.

  <node type="block" path="/Files/dev/sda" major="8" minor="0" uid="0" gid="0" mode="660" />

  A character device.

  <node type="char" path="/Files/dev/kmem" major="1" minor="2" uid="0" gid="kmem" mode="640" />

  A socket.

  <node type="socket" path="/Files/var/socket/mysocket" uid="0" gid="0" mode="600" />

  A fifo.

  <node type="fifo" path="/Files/var/fifo/myfifo" uid="0" gid="0" mode="600" />

  Delete an entry in the file system if it exists on the target.  This
  should not be confused with the <delete path="..." /> construct,
  which deletes entries from the what configuration tree (man What).

  <node type="delete" path="/Files/usr/sbin/bad-program" />

 </Files>
<what>


=cut

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

1;

