#! /local/bin/perl

######################################################################
# $Header: /loc/adm/slink-1.0/src/slink-5.0/Slink/RCS/Duper.pm,v 5.1 1996/05/15 20:23:04 couch Exp couch $
#  Slink::Duper.pm: duplicate things by copying or linking.
#  Revision 5.0
#  by
#  Alva L. Couch,                       
#  Associate Prof. of EE/CS          
#  Department of EE/CS             
#  Tufts University,            
#  Medford, Massachusetts, 02155.
#  couch@cs.tufts.edu
#
#  Copyright (C) 1996 by Alva L. Couch 
#
#  This file is part of SLINK
#
#  SLINK is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License as published by
#  the Free Software Foundation; either version 2, or (at your option)
#  any later version.
#
#  SLINK is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#
#  You should have received a copy of the GNU General Public License
#  along with GNU CC; see the file COPYING.  If not, write to
#  the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
######################################################################

package Slink::Duper; 
require 5.001;
require Exporter;
use Cwd;
use Config; 
use Slink::Mapper; 
use Slink::Logger; 
use Slink::Protector; 
use Slink::TrueName(qw(truename absolute prefix concat dontresolve)); 
use Slink::Omniopter; 
use strict;

BEGIN {
    @Slink::Duper::ISA = qw(Exporter);
    @Slink::Duper::EXPORT = qw();
    @Slink::Duper::EXPORT_OK = qw(); 

    # this is here so you can override it
    $Slink::Duper::cmd_cp = $Config::Config{'cp'}; 
}

# a Slink::Duper works because of an execution context telling it what to do. 
# This context is a hash to things it needs: 
# - a Slink::Logger to print to
# - a Slink::Mapper to modify
# - a Slink::Protector to define protection models. 
# Given a hash of these, check them and set up as an execution context.
sub new { 
    my ($module,$ref) = @_; 
    $ref = {} if ! defined $ref; 
    my $newref = bless [undef,undef,undef,undef]; 
    $newref->config($ref); 
    $newref->default; 
    return $newref; 
} 

# numeric offsets of Slink::Duper members
sub PROTECTOR { 0 }
sub MAPPER    { 1 }
sub LOGGER    { 2 }
sub DIRMODE   { 3 }

# Formal accessors for Slink::Duper members
sub protector { $_[0]->[PROTECTOR]; }
sub mapper    { $_[0]->[MAPPER];    }
sub logger    { $_[0]->[LOGGER];    }
sub dirmode   { $_[0]->[DIRMODE];   }

######################################################################
# set up resources so internal routines can print to logfiles, 
######################################################################

sub set_protector { 
    my ($this,$pro) = @_; 
    if (ref($pro) eq 'Slink::Protector') {
	$this->[PROTECTOR] = $pro; 
    } else {
	printf STDERR "passed ref isn't a Slink::Protector";
    }
}

sub set_mapper    { 
    my ($this,$map) = @_; 
    if (ref($map) eq 'Slink::Mapper') {
	$this->[MAPPER] = $map; 
    } else {
	printf STDERR "passed ref isn't a Slink::Mapper";
    }
}

sub set_logger    { 
    my ($this,$log) = @_; 
    if (ref($log) eq 'Slink::Logger') {
	$this->[LOGGER] = $log; 
    } else {
	printf STDERR "passed ref isn't a Slink::Logger";
    }
}

sub set_dirmode   {
    my($this,$mode) = @_; 
    $this->[DIRMODE] = $mode; 
}

# default unset or incorrect parameters
sub default {

    my ($this) = @_;

    if (! defined $this->logger) { 
	$this->set_logger(new Slink::Logger()); 
    } elsif (ref($this->logger) ne 'Slink::Logger')  {
	$this->set_logger(new Slink::Logger()); 
	$this->logger->error("replacing invalid Slink::Logger with default"); 
    }

    if (! defined $this->mapper) {
	$this->set_mapper(new Slink::Mapper()); 
	$this->logger->verbose("Slink::Duper using default Slink::Mapper"); 
    } elsif (ref($this->mapper) ne 'Slink::Mapper')  {
	$this->set_mapper(new Slink::Mapper()); 
	$this->logger->error("replacing invalid Slink::Mapper with default"); 
    }

    if (! defined $this->protector) {
	$this->set_protector(new Slink::Protector());
	$this->logger->error("WARNING: Slink::Duper using default Slink::Protector."); 
	$this->logger->error("WARNING: This disables filesystem changes."); 
    } elsif (ref($this->protector) ne 'Slink::Protector')  {
	$this->set_protector(new Slink::Protector());
	$this->logger->error("replacing invalid Slink::Protector with default"); 
	$this->logger->error("WARNING: Slink::Duper using default Slink::Protector."); 
	$this->logger->error("WARNING: This disables filesystem changes."); 
    }

    $this->set_dirmode(0755) if ! defined $this->dirmode; 
}

# configure a Slink::Duper from a hash table
sub config {
    my ($this,$hash) = @_; 
    my (@illegal) = Slink::Omniopter::illegal($hash, 
	'protector','mapper','logger','dirmode'); 
    if (@illegal) {
	my $illegal = join(' ',@illegal); 
	print STDERR "config: illegal options $illegal\n"; 
    }
    
    $this->set_protector($hash->{'protector'})
	if (defined $hash->{'protector'}); 
    $this->set_mapper($hash->{'mapper'})
	if (defined $hash->{'mapper'}); 
    $this->set_logger($hash->{'logger'})
	if (defined $hash->{'logger'}); 
    $this->set_dirmode($hash->{'dirmode'})
	if (defined $hash->{'dirmode'}); 
}

  ##################################################################
 ####                                                            ####
####    High level operations for normal users default the setup  ####
 ####                                                            ####
  ##################################################################

sub link    { 
    my ($this,$source,@images) = @_; 
    my $ret = 1; 
    my $image; 
    foreach $image (@images) {
	$ret = 0 if ! $this->link_node($source,$image); 
    }
    return $ret; 
}

sub unlink    { 
    my ($this,$source,@images) = @_; 
    my $ret = 1; 
    my $image; 
    foreach $image (@images) {
	$ret = 0 if ! $this->unlink_node($source,$image); 
    }
    return $ret; 
}

sub copy    { 
    my ($this,$source,@images) = @_; 
    my $ret = 1; 
    my $image; 
    foreach $image (@images) {
	$ret = 0 if ! $this->copy_node($source,$image);
    }
    return $ret; 
}

sub uncopy    { 
    my ($this,$source,@images) = @_; 
    my $ret = 1; 
    my $image; 
    foreach $image (@images) {
	$ret = 0 if ! $this->uncopy_node($source,$image);
    }
    return $ret; 
}

sub destroy    { 
    my ($this,@images) = @_; 
    my $ret = 1; 
    my $image; 
    foreach $image (@images) {
	$ret = 0 if ! $this->destroy_node($image);
    }
    return $ret; 
}

  ##################################################################
 ####                                                            ####
####          Link and unlink hierarchies from image trees        ####
 ####                                                            ####
  ##################################################################

######################################################################
# Link $image to $sourc, recording and correcting existing incorrect 
# links.  When encountering directories in source,
# copy directory structure recursively.	
# Preconditions: 
#  $sourc: source of the slink
#  $image: image of the source.
#  $this->logger is open to allow printing of log and error messages.
#  $this->mapper is initialized to describe current link structure. 
# Postconditions: 
# Either:
#  the link is made, 
#  structural changes are described by log messages in $this->logger. 
#  $this->mapper is modified to reflect changes in link structure,
#  and the return value is 1, 
# Or
#  the link cannot be made due to physical or model problems, 
#  the reason is printed in $this->logger, 
#  $this->mapper is modified to reflect changes in link structure,
#  and the return value is 0. 
######################################################################

sub link_node {
    my($this,$sourc,$image) = @_; 
    $this->logger->debug("link_node($sourc,$image)"); 
    $this->logger->debug("trying to link $image => $sourc"); 

    # note: you don't need to be able to read a file to make it available
    # but you do have to be able to get to its directory
    my ($trusourc) = &truename($sourc); 
    (defined $trusourc) 
	|| return $this->logger->error("ignoring nonexistant source $sourc"); 
    ($trusourc ne '') 
	|| return $this->logger->error("ignoring inaccessible source $sourc"); 

    $this->logger->debug("linking $image => truename $trusourc"); 

    if (&isame($image,$trusourc)) {
	if (-l $image) {
	    my $oldtarg = readlink($image); 
	    if ($oldtarg eq $trusourc) {
		$this->mapper->add('link',$trusourc,$image); 
		return 1; 
	    } else {
		# relink without remapping
		$this->mapper->del($image); 
		$this->destroy_node($image) || return 0;
		$this->make_link($trusourc,$image) || return 0; 
		return 1; 
	    }
	}
    } elsif (-d $image && -d $trusourc) {	# both are directories
	$this->logger->verbose("linking dir $image => $sourc"); 
	opendir(DIR,"$trusourc") 
	    || return $this->logger->error(
		"can't open directory $trusourc: $!"); 
	my @contents = readdir DIR; closedir DIR; 
	my($works)=1; 
	my($entry); 
	foreach $entry (@contents) {
	    next if ($entry eq '.' || $entry eq '..'); 
	    $this->link_node(&concat($trusourc,$entry),&concat($image,$entry)) 
		|| ($works=0);
	}
	return $works; 
    } else {				# one isn't a directory
	$this->logger->verbose("linking $image -> $sourc"); 
	$this->make_path_to($image) || return 0; 
        if (-e $image || -l $image) { 
	    $this->destroy_node($image) || return 0; 
  	}
	$this->make_link ($trusourc,$image) || return 0; 
	return 1; 
    }
}

######################################################################
# remove links between two nodes, wherever they are
# Preconditions: 
#  $sourc: source of the slink
#  $image: image of the source.
#  $this->logger is open to allow printing of log and error messages.
#  $this->mapper is initialized to describe current link structure. 
# Postconditions: 
# Either:
#  the nodes can be unlinked or are already unlinked, 
#  structural changes are described using $this->logger->mesg,
#  $this->mapper is modified to reflect changes in link structure,
#  and the return value is 1, 
# Or
#  we cannot unlink the nodes due to physical or model problems, 
#  the reason is described using $this->logger->error. 
#  structural changes are described using $this->logger->mesg.
#  $this->mapper is modified to reflect changes in link structure,
#  and the return value is 0. 
######################################################################

sub unlink_node {
    my($this,$sourc,$image) = @_; 
    $this->logger->debug("unlink_node($sourc,$image)"); 

    $this->logger->debug("trying to unlink $image !=> $sourc"); 

    # note: you don't need to be able to read a file to make it available
    # but you do have to be able to get to its directory
    my ($trusourc) = &Slink::TrueName::truename($sourc); 
    (defined $trusourc) 
	|| return $this->logger->error("ignoring nonexistant source $sourc"); 
    ($trusourc ne '') 
	|| return $this->logger->error("ignoring inaccessible source $sourc"); 

    $this->logger->debug("unlinking $image => truename $trusourc"); 

    #if it's not there, we're done already!
    return 1 if ! -e $image;

    # if the file is already a link, then unlink it
    # ONLY IF it points to the wrong place. 
    if (-l $image) {
	return 1 if ! &isame($image,$trusourc); 
	$this->logger->verbose("unlinking $image !-> $sourc"); 
	$this->destroy_node($image) || return 0; 
	return 1; 

    # if the node is a directory, then try double descent
    } elsif (-d $image && -d $trusourc) {	
	$this->logger->verbose("unlinking dir $image !=> $sourc"); 
	opendir(DIR,"$trusourc") 
	    || return $this->logger->error("can't open directory $trusourc: $!"); 
	my @contents = readdir DIR; closedir DIR; 
	my($works)=1; 
	my($entry); 
	foreach $entry (@contents) {
	    next if ($entry eq '.' || $entry eq '..'); 
	    $this->unlink_node(
		&concat($trusourc,$entry),
	        &concat($image,$entry)) 
		|| ($works=0);
	}
	return $works; 
    } 

    # else there's no link so you can't delete it. 
    return 1; 
}

  ##################################################################
 ####                                                            ####
####   Copy and uncopy files into image trees, adjusting links    ####
 ####                                                            ####
  ##################################################################

######################################################################
# Copy $image to $sourc, embedding files in place of links. 
# When encountering directories in source,
# copy directory structure recursively.	
# Preconditions: 
#  $sourc: thing to copy.
#  $image: where to copy it to. 
#  $this->logger is open to allow printing of log and error messages.
#  $this->mapper is initialized to describe current link structure. 
# Postconditions: 
# Either:
#  the copy is made, 
#  structural changes are described using $this->logger->mesg,
#  $this->mapper is modified to reflect changes in link structure,
#  and the return value is 1, 
# Or
#  the link cannot be made due to physical or model problems, 
#  the reason is printed using $this->logger->error,
#  structural changes are described using $this->logger->mesg,
#  $this->mapper is modified to reflect changes in link structure,
#  and the return value is 0. 
######################################################################

sub copy_node {
    my($this,$sourc,$image) = @_; 
    $this->logger->debug("copy_node($sourc,$image)"); 
    $this->logger->debug("trying to copy $sourc to $image"); 

    # note: you don't need to be able to read a file to make it available
    (-e $sourc) || return $this->logger->error("ignoring nonexistant source $sourc"); 

    if (-d $sourc) {
	if (! -d $image) {
	    if (-e $image || -l $image) { 
		$this->destroy_node($image) || return 0; 
	    }
	    $this->make_path_to($image) || return 0; 
	    $this->make_directory($image,$this->dirmode) || return 0; 
	}
	$this->logger->verbose("copying dir $sourc to $image"); 
	opendir(DIR,"$sourc") 
	    || return $this->logger->error("can't open directory $sourc: $!"); 
	my @contents = readdir DIR; closedir DIR; 
	my($works)=1; 
	my($entry); 
	foreach $entry (@contents) {
	    next if ($entry eq '.' || $entry eq '..'); 
	    $this->copy_node(
		&concat($sourc,$entry),
		&concat($image,$entry)) 
		|| ($works=0);
	}
	return $works; 
    } elsif (-f $sourc) {
	if (-l $image || ! -f $image) {
	    if (-e $image || -l $image) { 
		$this->destroy_node($image) || return 0; 
	    }
	}
	if (! &csame($image,$sourc) || -l $image) {
	    $this->logger->verbose("copying file $sourc to $image"); 
	    if (-e $image || -l $image) { 
		$this->destroy_node($image) || return 0; 
 	    }
	    $this->make_path_to($image) || return 0; 
	    $this->make_copy($sourc,$image) || return 0; 
	    return 1; 
	}
    } else {
	return $this->logger->error("can't copy non-file $sourc"); 
    }
}

######################################################################
# remove a copy of a thing.
# Preconditions: 
#  $sourc: a prototype.
#  $image: copy to remove. 
#  $this->logger is open to allow printing of log and error messages.
#  $this->mapper is initialized to describe current link structure. 
# Postconditions: 
# Either:
#  the copy can be deleted or is already deleted, 
#  structural changes are described using $this->logger->mesg,
#  $this->mapper is modified to reflect changes in link structure,
#  and the return value is 1, 
# Or
#  we cannot delete the node(s) due to physical or model problems, 
#  the reason is printed using $this->logger->error,
#  structural changes are described using $this->logger->mesg,
#  $this->mapper is modified to reflect changes in link structure,
#  and the return value is 0. 
######################################################################

sub uncopy_node {
    my($this,$sourc,$image) = @_; 
    $this->logger->debug("uncopy_node($sourc,$image)"); 

    $this->logger->debug("trying to uncopy $sourc to $image"); 

    # note: you don't have to be able to read a file to make it available 
    (-e $sourc) || return $this->logger->error("ignoring nonexistant source $sourc"); 

    #if it's not there, we're done already!
    return 1 if ! -e $image;

    # if the file is a copy, then unlink it
    # ONLY IF it is a copy of the wrong thing. 
    if (-l $image) {
	return 1; 
    } elsif (-d $image && -d $sourc) {	
	$this->logger->verbose("uncopying dir $sourc to $image"); 
	opendir(DIR,"$sourc") 
	    || return $this->logger->error("can't open directory $sourc: $!"); 
	my @contents = readdir DIR; closedir DIR; 
	my($works)=1; 
	my($entry); 
	foreach $entry (@contents) {
	    next if ($entry eq '.' || $entry eq '..'); 
	    $this->uncopy_node(&concat($sourc,$entry),&concat($image,$entry)) 
		|| ($works=0);
	}
	return $works; 
    } elsif (-f $sourc && -f $image) {
	return 1 if ! &csame($image,$sourc); 
	$this->logger->verbose("uncopying file $sourc to $image"); 
	$this->destroy_node($image) || return 0; 
	return 1; 
    }

    # else there's no link so you can't delete it. 
    return 1; 
}

  ##################################################################
 ####                                                            ####
####   Condenser optimizes directory structure after cleanup      ####
 ####                                                            ####
  ##################################################################

#####################################################################
# condensing routine:
#  if a link directory is exactly equivalent to a source directory,
#  then delete the link directory and replace it with a single link.
#  Don't condense if the two directories represent the same inode.
# Preconditions: 
#  $sourc: source of the slink. 
#  $image: image of the source.
#  $this->logger is open to allow printing of log and error messages.
#  $this->mapper is initialized to describe current link structure. 
# Postconditions: 
# Either:
#  the image is condensed, 
#  structural changes are described using $this->logger->mesg,
#  $this->mapper is modified to reflect changes in link structure,
#  and the return value is 1, 
# Or
#  the image cannot be condensed due to physical or model problems, 
#  the reason is printed using $this->logger->error,
#  structural changes are described using $this->logger->mesg,
#  $this->mapper is modified to reflect changes in link structure,
#  and the return value is 0. 
#####################################################################

sub condense_node {
    my ($this, $sourc, $image) = @_; 
    $this->logger->debug("condense_node($sourc,$image)");

    # check whether files are identical
    if ($sourc eq $image) {
	# $this->logger->debug("condense: $sourc is identical with $image"); 
	# $this->logger->debug("condense: $sourc === $image"); 
	return 0; 		# oops, identical files, one copy, don't delete
    } elsif (-l $image) {
	my ($oldsourc) = readlink($image); 
	my ($abssourc) = &absolute($oldsourc,&prefix($image)); 

	if (! -e $abssourc) {
	    return $this->destroy_node($image); 
	} elsif (&isame($sourc, $image)) {
	    # $this->logger->debug("condense: $sourc and $image are equivalent"); 
	    # $this->logger->debug("condense: $sourc =.= $image"); 
	    return 1;		# image file is same as source
 	} else {
	    # $this->logger->debug("condense: $image is not a symlink to $sourc"); 
	    # $this->logger->debug("condense: $sourc =!= $image"); 
	    return 0; 		# oops, not a link
 	}
    } elsif (-d $image) {
        if (! -d $sourc) {
	    # $this->logger->debug("condense: $image is a directory and $sourc isn't"); 
	    # $this->logger->debug("condense: $sourc =!= $image"); 
	    return 0; 
	}

	# first head-recurse down the tree and try to condense lower levels
	# this will guarantee that the effects of condensing lower levels
        # will be felt when upper levels are condensed. 
        my ($success) = $this->condense_directory($sourc,$image); 
        my $model = $this->protector->query($image);	 
	my $name = $model->name; 
        if ($success && $model->may_redirect) { 
	    # $this->logger->debug("condense: $sourc =.= $image");
	    $this->logger->verbose("condensing directory $image into a link -> $sourc"); 
	    $this->destroy_node_physical($image) || return 0; 
	    $this->make_link($sourc,$image) || return 0; 
	    $this->logger->mesg("condense directory $image into a link -> $sourc"); 
	    return 1; 
        } else {
	    return $this->logger->warning("may not redirect $image (model $name)"); 
	}
    } else {		# there's a file in the image
	# $this->logger->debug("condense: $image isn't a link or directory"); 
 	# $this->logger->debug("condense: $sourc =!= $image"); 
	return 0; 
    }
}

#####################################################################
# condense one pair of directories if possible
# head-recurse down the tree and try to condense lower levels first
# Preconditions: 
#  $sourc: source of the slink, must be a directory
#  $image: image of the source, must be a directory
#  $this->logger is open to allow printing of log and error messages.
#  $this->mapper is initialized to describe current link structure. 
# Postconditions: 
# Either:
#  the image is condensed, 
#  structural changes are described using $this->logger->mesg,
#  $this->mapper is modified to reflect changes in link structure,
#  and the return value is 1, 
# Or
#  the image cannot be condensed due to physical or model problems, 
#  the reason is printed using $this->logger->error,
#  structural changes are described using $this->logger->mesg,
#  $this->mapper is modified to reflect changes in link structure,
#  and the return value is 0. 
#####################################################################

sub condense_directory {
    my($this,$sourc,$image) = @_; 
    $this->logger->debug("condense_directory($sourc,$image)");

    my($success) = 1; 

    # first scan the directory looking for things to coalesce. 
    opendir(DIR, $image)
	|| return $this->logger->error("cannot open directory $image"); 
    my (@imagelist) = sort readdir(DIR);
    my $node; 
    foreach $node (@imagelist) {
	next if ($node eq '.' || $node eq '..'); 
	if (!$this->condense_node(
	    &concat($sourc,$node),
	    &concat($image,$node))) {
	    $success=0; # must continue coalescing at this level
	}
    }
    return 0 if !$success; 

    # if all the contents of this directory are links, 
    # and it's confluent to the source, then return 1. 
    opendir(DIR, $sourc)
	|| return $this->logger->error("cannot open directory $sourc"); 
    my (@sourclist) = sort readdir(DIR);

    # if not the same number of elements, then not confluent. 
    if (@sourclist != @imagelist) { 
	# $this->logger->debug("condense: |$sourc| and |$image| differ"); 
 	return 0; 
    } 

    # if not the same elements, then not confluent. 
    my $i; 
    for ($i=0; $i<@sourclist; $i++) {
	if ($sourclist[$i] ne $imagelist[$i]) {
	    # $this->logger->debug("condense: contents of $sourc and $image differ"); 
	    return 0; 
	}
    }
    return 1; 
}

  ##################################################################
 ####                                                            ####
####     Cleaner removes meaningless links from image trees       ####
 ####                                                            ####
  ##################################################################

######################################################################
# point-to-point link cleanup
# check one link and remove it if it points nowhere.
# if it's a directory, recursively clean subdirectories.
# Preconditions: 
#  $node: absolute pathname of node to clean. 
#  $this->logger is open to allow printing of log and error messages.
#  $this->mapper is initialized to describe current link structure. 
# Postconditions: 
# Either: 
#  $node and its subtrees contain no nonexistant (dangling) links,
#  structural changes are described using $this->logger->mesg,
#  $this->mapper is modified to reflect changes in link structure,
#  and the return value is 1, 
# Or
#  dangling links cannot be removed for physical or model reasons, 
#  the reason is printed using $this->logger->error,
#  structural changes are described using $this->logger->mesg,
#  $this->mapper is modified to reflect changes in link structure,
#  and the return value is 0. 
######################################################################

sub clean_node {
    my ($this,$node) = @_; 
    $this->logger->debug("clean_node($node)"); 
    if (-l $node) {
	my ($oldsourc) = readlink($node); 
	my ($abssourc) = &absolute($oldsourc,&prefix($node)); 

	# note: you don't need to be able to read a file to make it available
	# but you do have to be able to get to its directory
	my ($trusourc) = &Slink::TrueName::truename($abssourc); 
	if (! defined $trusourc) {
	    $this->logger->verbose("removing nonexistent link $node -> $oldsourc\n"); 
	    return $this->destroy_node($node); 
	} elsif ($trusourc eq '') {
	    return $this->logger->error("ignoring inaccessible source $abssourc");
	} 
	return 1; 
    } elsif (-d $node) {
	opendir(DIR,$node) 
	    || return $this->logger->error("can't open directory $node: $!"); 
	my @contents = readdir DIR; closedir DIR; 
	my ($worked) = 1; 
	my ($entry); 
	foreach $entry (@contents) {
	    next if ($entry eq '.'  || $entry eq '..'); 
	    $this->clean_node(&concat($node,$entry)) 
		|| ($worked = 0); 
	}
	return $worked; 
    } else {
	return 1; 
    }
}

  ##################################################################
 ####                                                            ####
####           Reporter reports problems in image trees           ####
 ####                                                            ####
  ##################################################################

######################################################################
# point-to-point link unraveling to determine how corrupt 
# the link tree has become due to direct user actions.
# if it's a directory, recursively unravel subdirectories.
# Preconditions: 
#  $node: absolute pathname of node to check, which can be anything. 
#  $this->logger is open to allow printing of log and error messages.
#  $this->mapper is initialized to describe current link structure. 
#  main::NEW is an open file descriptor.
# Postconditions: 
#  possible corruption is described on STDERR. 
#  links not made by slink are described in main::NEW. 
#  return value is 1 if no possible problems are reported, 
#  0 if some problems were found. 
######################################################################

sub report_node {
    my ($this,$node) = @_; 
    $this->logger->debug("report_node($node)"); 

    if (-l $node) {
	my ($oldsourc) = readlink($node); 
	my ($abssourc) = &absolute($oldsourc,&prefix($node));

	# note: you don't need to be able to read a file to make it available
	# but you do have to be able to get to its directory
	my ($trusourc) = &Slink::TrueName::truename($abssourc); 

	if (! defined $trusourc) {
	    print STDERR "found dangling link $node -> $oldsourc\n";
	    return 0; 
        } elsif ($trusourc eq '') {
	    print STDERR "ignoring inaccessible link $node -> $oldsourc\n"; 
	    return 1; 
	} else {
	    if (! $this->mapper->mapped('link',$oldsourc,$node)) { 
		print STDERR "slink did not create $node -> $oldsourc\n"; 
		print main::NEW "link $abssourc $node\n";
	        return 0; 
  	    } else {
		return 1; 
	    }
        }
    } elsif (! -e $node) {
	print STDERR "slink: node $node does not exist\n"; 
    } elsif (-d $node) {
	opendir(DIR,$node) 
	    || return $this->logger->error("can't open directory $node: $!"); 
 	my @contents = readdir DIR; closedir DIR; 
	my ($worked) = 1; 
	my ($entry); 
	foreach $entry (@contents) {
	    next if ($entry eq '.'  || $entry eq '..'); 
	    $this->report_node(&concat($node,$entry)) || ($worked = 0); 
	}
	return $worked; 
    } elsif (-f $node) { 	# normal file in link tree!
	my $ref = $this->mapper->source($node); 
        if (! defined $ref  || $ref->[0] ne 'copy') {
	    print STDERR "slink did not create file $node\n"; 
	    print main::NEW "# copy ? $node\n"; 
	    return 0; 
	} elsif (! csame($node,$ref->[1])) {
	    print STDERR "slink should have created file $node, but didn't!\n"; 
	    print main::NEW "# copy ? $node\n"; 
	    return 0; 
	} else {
	    return 1; 
	}
    } else {
	print STDERR "slink did not create node $node\n"; 
	print main::NEW "# ? ? $node\n";
	return 0; 
    }
}

  ##################################################################
 ####                                                            ####
####  Constructors create links, files, directories, paths        ####
 ####                                                            ####
  ##################################################################

######################################################################
# make a link via a symlink call, but log the result in logfiles
# and the mapfile for future reference. 
# Preconditions: 
#  $source and $image are suitable for a symlink call. 
#  $this->logger is open to allow printing of log and error messages.
#  $this->mapper is initialized to describe current link structure. 
# Postconditions: 
# Either
#  the link can be constructed, 
#  structural changes are described using $this->logger->mesg,
#  $this->mapper is updated for the existence of the new link,
#  and the return value is 1. 
# Or
#  the link cannot be made, 
#  the reason is printed using $this->logger->error,
#  and the return value is 0. 
######################################################################

sub make_link {
    my ($this,$source,$image) = @_; 
    $this->logger->verbose("making link $image -> $source"); 
    my $mtype = $this->protector->query($image); 
    my $model = $mtype->name; 
    $mtype->may_contribute 
     || return $this->logger->warning("may not make link $image -> $source (model '$model')"); 
    symlink ($source,$image) 
     || return $this->logger->error("cannot link $image -> $source: $!");
    $this->logger->mesg("make link $image -> $source"); 
    $this->mapper->add('link',$source,$image);
    return 1; 
}

######################################################################
# make a copy of a file, but log the result in logfiles
# and the mapfile for future reference. 
# Preconditions: 
#  $source and $image are file pathnames. 
#  $this->logger is open to allow printing of log and error messages.
#  $this->mapper is initialized to describe current link structure. 
# Postconditions: 
# Either
#  the copy can be constructed, 
#  structural changes are described using $this->logger->mesg,
#  $this->mapper is updated for the existence of the new link,
#  and the return value is 1. 
# Or
#  the copy cannot be made, 
#  the reason is printed using $this->logger->error,
#  and the return value is 0. 
######################################################################

sub make_copy {
    my ($this, $source, $image) = @_; 
    $this->logger->verbose("making copy $source to $image"); 
    my $mtype = $this->protector->query($image); 
    my $model = $mtype->name; 
    $mtype->may_contribute 
     || return $this->logger->warning("may not copy $source to $image (model '$model')"); 
    $this->make_copy_file ($source,$image) 
     || return $this->logger->error("cannot copy $source to $image: $!");
    $this->logger->mesg("make copy $source to $image"); 
    $this->mapper->add('copy',$source,$image);
    return 1; 
}

# copy one file to another place. 
# correct all file stats possible to correct. 
# if suid or sgid and current invoker isn't 
# an appropriate user or in the appropriate group,
# then warn about sgid and don't copy. 
sub make_copy_file { 
    my($this, $source, $image) = @_; 
    my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
	$atime,$mtime,$ctime,$blksize,$blocks) = stat($source);
    if ($< == 0) {
	! (system ("$Slink::Duper::cmd_cp $source $image")/256) || return 0; 
	chown $uid,$gid,$image; 
	utime $atime,$mtime,$image; 
	chmod $mode,$image; 
	return 1; 
    } else {
	if (-u $source && ! -o $source) {
	    return $this->logger->error("can't setuid a copy of $source"); 
	}
	my @groups = split (/[ \t]+/,$)); 
        if (-g $source && ! &member($gid,@groups)) {
	    return $this->logger->error("can't setgid a copy of $source"); 
	}
	if (-k $source) {
	    return $this->logger->error("can't set the sticky bit in copying $source"); 
	}
	! (system ("$Slink::Duper::cmd_cp $source $image")/256) || return 0; 
	my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
	    $atime,$mtime,$ctime,$blksize,$blocks) = stat($source);
	chown $<,$gid,$image; 
	utime $atime,$mtime,$image; 
	chmod $mode,$image; 
	return 1; 
    }
}

# set membership
sub member {
    my ($target,@set) = @_; 
    my $sample; 
    foreach $sample (@set) { return 1 if $sample eq $target; }
    return 0; 
}

######################################################################
# make a directory via a mkdir call, and record the act in logfiles
# Preconditions: 
#  $dir and $mode are suitable for a mkdir call. 
#  $this->logger is open to allow printing of log and error messages.
#  $this->mapper is initialized to describe current link structure. 
# Postconditions: 
# Either
#  the directory is constructed, 
#  the act is described using $this->logger->mesg, 
#  and the return value is 1. 
# Or
#  the directory cannot be constructed, 
#  the reason is described using $this->logger->error,
#  and the return value is 0. 
######################################################################

sub make_directory {
    my($this,$dir,$mode)=@_; 
    $this->logger->verbose("making directory $dir"); 
    my $mtype = $this->protector->query($dir); 
    my $model = $mtype->name; 
    $mtype->may_contribute 
     || return $this->logger->warning("may not make directory $dir (model '$model')"); 
    mkdir($dir, $mode) 
     || return $this->logger->error("cannot make directory $dir: $!"); 
    $this->logger->mesg("make directory $dir");
    return 1; 
}

######################################################################
# this little dance replaces links to directories with directories 
# of links repeatedly until only the last component of $image 
# potentially contains a link. 
# Preconditions: 
#  $image is an absolute pathname to make.
#  $this->logger is open to allow printing of log and error messages.
#  $this->mapper is initialized to describe current link structure. 
# Postconditions: 
# Either
#  $image contains a link at potentially the last position, 
#  but is otherwise contained in exactly one tree, 
#  structural changes are described using $this->logger->mesg,
#  $this->mapper is modified to reflect changes in link structure,
#  and the return value is 1, 
# Or 
#  the modification couldn't be performed, 
#  the reason is printed using $this->logger->error,
#  structural changes are described using $this->logger->mesg,
#  $this->mapper is modified to reflect changes in link structure,
#  and the return value is 0. 
######################################################################

sub make_path_to {
    my($this,$image) = @_; 
    $this->logger->debug("make_path_to($image)"); 

    # compute all prefixes and mutate them into directories if possible
    my(@image) = split("/",$image); 
    my($i); 
    for ($i=1; $i<$#image; $i++) {
	my($path) = join("/",@image[0..$i]); 
	if (-l $path && -e $path) {
	    my($oldsourc)=readlink($path); 
	    if (!&Slink::TrueName::dontresolve($oldsourc)) {	# don't brachiate automounts
		my $abssourc = &absolute($oldsourc,&prefix($path));
		$this->logger->verbose("promoting $path -> $oldsourc from link to directory.");
		$this->destroy_node($path) || return 0; 
		$this->make_directory($path,$this->dirmode) || return 0; 
		$this->link_node($abssourc,$path) || return 0; 
		$this->logger->mesg("promote $path -> $oldsourc from link to directory.");
	    } else {
		$this->logger->verbose("Skipping automount point $path"); 
	    }
	} elsif (! -d $path) {
	    if (-e $path || -l $path) {
		$this->logger->verbose("mutating $path into a directory.");
		$this->destroy_node($path) || return 0; 
		$this->make_directory($path,$this->dirmode) || return 0;
		$this->logger->mesg("mutate $path into a directory.");
	    } else {
		$this->make_directory($path,$this->dirmode) || return 0;
	    }
	}
    }
    return 1;
}

  ##################################################################
 ####                                                            ####
####   Destroyers remove either a file or directory (any depth)   ####
 ####                                                            ####
  ##################################################################

######################################################################
# remove either a directory or other node.  Descend into directories 
# and remove whole directory hierarchies if necessary.  
# (one must have this because perl will corrupt directory structure 
# if you unlink a directory as root!)
# Preconditions: 
#  $node is the node to remove, which can be anything
#  $this->logger is open to allow printing of log and error messages.
#  $this->mapper is initialized to describe current link structure. 
# Postconditions: 
# Either 
#  $node is removed, 
#  structural changes are described using $this->logger->mesg,
#  $this->mapper is modified to reflect changes in link structure,
#  and the return value is 1. 
# Or
#  $node cannot be removed, either physically or 
#  according to the storage model, 
#  the reason is printed using $this->logger->error,
#  structural changes are described using $this->logger->mesg,
#  $this->mapper is modified to reflect changes in link structure,
#  and the return value is 0. 
######################################################################

sub destroy_node {
    my($this,$node)=@_; 
    # $this->logger->debug("destroy_node($node)");
    return 1 if ! -e $node && ! -l $node; 

    my ($model) = $this->protector->query($node); 
    my ($mname) = $model->name; 
    if (-l $node) {
	my($oldsourc) = readlink($node); 
	my($abssourc) = &absolute($oldsourc,&prefix($node));
	$model->may_relink
	 || return $this->logger->warning(
	    "may not remove link $node -> $oldsourc (model '$mname')"); 
	$this->logger->verbose("removing link $node -> $oldsourc"); 
	unlink($node)
	    || return $this->logger->error(
		"cannot remove link $node -> $oldsourc: $!");
	if (-e $abssourc) {
	     $this->logger->mesg("remove valid link $node -> $oldsourc"); 
	} else {
	     $this->logger->mesg("remove dangling link $node -> $oldsourc"); 
	}
	$this->mapper->del($node);
	return 1; 
    } elsif (-d $node) {
	$model->may_prune
	    || return $this->logger->warning(
		"may not remove directory $node (model '$mname')"); 
	$this->logger->verbose("removing directory $node"); 
	opendir(DIR,"$node") 
	    || return $this->logger->error("cannot read directory $node: $!");
	# remove all nodes from the directory 
	my($worked)=1; 
	my($entry); 
	foreach $entry (readdir DIR) {
	    next if ($entry eq '.' || $entry eq '..'); 
	    $this->destroy_node(&concat($node,$entry)) 
		|| ($worked=0); 
	}
	return 0 if ! $worked; 
	rmdir($node) 
	    || return $this->logger->error("cannot remove directory $node: $!");
	return $this->logger->mesg("remove directory $node"); 
    } else { # a regular file; I don't care what kind
	$model->may_replace
	    || return $this->logger->warning(
		"may not remove node $node (model '$mname')"); 
	$this->logger->verbose("removing file $node"); 
	unlink($node)
	    || return $this->logger->error("cannot remove file $node: $!"); 
	$this->mapper->del($node);
	return $this->logger->mesg("remove file $node"); 
    }
    return 1; 
}

# ignore virtual protection in destroying a thing
sub destroy_node_physical {
    my($this,$node)=@_; 
    # $this->logger->debug("destroy_node($node)");
    return 1 if ! -e $node && ! -l $node; 

    if (-l $node) {
	my($oldsourc) = readlink($node); 
	my($abssourc) = &absolute($oldsourc,&prefix($node));
	$this->logger->verbose("removing link $node -> $oldsourc"); 
	unlink($node)
	    || return $this->logger->error(
		"cannot remove link $node -> $oldsourc: $!");
	if (-e $abssourc) {
	     $this->logger->mesg("remove valid link $node -> $oldsourc"); 
	} else {
	     $this->logger->mesg("remove dangling link $node -> $oldsourc"); 
	}
	$this->mapper->del($node);
	return 1; 
    } elsif (-d $node) {
	$this->logger->verbose("removing directory $node"); 
	opendir(DIR,"$node") 
	    || return $this->logger->error("cannot read directory $node: $!");
	# remove all nodes from the directory 
	my($worked)=1; 
	my($entry); 
	foreach $entry (readdir DIR) {
	    next if ($entry eq '.' || $entry eq '..'); 
	    $this->destroy_node_physical(&concat($node,$entry)) 
		|| ($worked=0); 
	}
	return 0 if ! $worked; 
	rmdir($node) 
	    || return $this->logger->error("cannot remove directory $node: $!");
	return $this->logger->mesg("remove directory $node"); 
    } else { # a regular file; I don't care what kind
	$this->logger->verbose("removing file $node"); 
	unlink($node)
	    || return $this->logger->error("cannot remove file $node: $!"); 
	$this->mapper->del($node);
	return $this->logger->mesg("remove file $node"); 
    }
    return 1; 
}

  ##################################################################
 ####                                                            ####
####   Utilities determine whether two files are the same or no   ####
 ####                                                            ####
  ##################################################################

######################################################################
# check whether two paths are indistinguishable
# returns 1 if two inodes are exactly the same, 0 if not. 
# note: returns 1 if NEITHER exists, as then indeed
# they're indistinguishable :). 
######################################################################

sub isame {
  my ($file1, $file2) = @_;
  my ($dev1, $inode1) = stat($file1);
  my ($dev2, $inode2) = stat($file2);
  return $inode1 == $inode2 && $dev1 == $dev2;
}

######################################################################
# check whether two files are copies of each other
# returns 1 if so, 0 if they're not or they're different types.
######################################################################

sub csame { 
    my ($file1, $file2) = @_; 
    if (-l $file1 && -l $file2) {
	return 1 if readlink($file1) eq readlink($file2); 
	return 0; 
    }
    if (-f $file1 && -f $file2) {
        my ($dev1,$ino1,$mode1,$nlink1,$uid1,$gid1,$rdev1,$size1,
            $atime1,$mtime1,$ctime1,$blksize1,$blocks1) = stat($file1);
        my ($dev2,$ino2,$mode2,$nlink2,$uid2,$gid2,$rdev2,$size2,
            $atime2,$mtime2,$ctime2,$blksize2,$blocks2) = stat($file2);
	return 1 if $size1 == $size2 && $mtime1 == $mtime2; 
	return 0; 
    }
    return 0; 
}

######################################################################
# check whether two files are hard links to the same inode. 
# returns 1 if so, 0 if they're not or they're different types.
######################################################################

sub lsame { 
    my ($file1, $file2) = @_; 
    return 0 if -l $file1 || -l $file2; 
    return 0 if ! -f $file1 || ! -f $file2; 
    return &isame($file1,$file2); 
}

1;