#! /local/bin/perl
######################################################################
# $Header: /loc/adm/slink-1.0/src/RCS/slink,v 2.4 1996/04/10 20:56:38 couch Exp couch $
#  SLINK the link manager: create virtual unions of filesystem subtrees. 
#  Revision 2.0
#  by 
#  Alva L. Couch, 			Greg Owen
#  Associate Prof. of EE/CS		Xerox Information Systems
#  Department of EE/CS			Peabody, MA 02146
#  Tufts University,			gowen@xis.xerox.com
#  Medford, Massachusetts, 02155.
#  couch@cs.tufts.edu
#
#  Copyright (C) 1995 by Alva L. Couch and Greg Owen
# 
#  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.
######################################################################
#  Slink the link manager manages creation of virtual symbolic images
#  of UNIX filesystem subtrees.  Each image is a union constructed from 
#  symbolic links. A configuration file has entries of the form: 
#  <target-root> <image-root> [<protection-mode>]
#  where
#  <target-root> is what to add to the image, e.g., /loc/emacs-19
#  <image-root>  is where to make the first node appear in an image, 
#		 e.g., /local, /local/bin, etc.
#  <protection-mode> describes how much control we allow the program
#                to assert in the image tree. There are 4 levels: 
#   protect: can't change anything that already exists
#   relink: can change links into other links, files, or directories
#   redirect: can change directories into links or files. 
#   replace: can change files into links or directories. 
#
#  Relink is the default model for link requests, while
#  redirect is the default model for condensing requests.
#
#  Link requests can be undone with the configuration file line
#  ! <target-root> <image-root> [<protection-mode>]
#
#  Example: the line
#  /loc/emacs-19 /local redirect
#  means to recursively make links from /local/file 
#  to /loc/emacs-19/file for every file in /loc/emacs-19/file, 
#
#  Entries in each column can be absolute or relative.
#  Relative addresses are prepended with absolute prefixes. 
#  Lines of the form: 
#  + cwd1 cwd2 model
#  set the working directories for each column, as well as the 
#  default protection model. 
#
#  One may delegate commands to subfiles and include a file with the line
#  +file cwd1 cwd2 model
#  where
#  a) file will be expanded relative to the current working directory
#     for the target column (#1). 
#  b) cwd1, cwd2 are working directories to use INSIDE the file. 
#     (which will be restored to their old values upon coming back from it)
#  c) model is the default protection model to use INSIDE the file. 
#     (which will be restored to its old value upon coming back from it)
#
#  " in a directory or protection position means leave current setting alone.
######################################################################

require "getcwd.pl"; 
require "ctime.pl";
require "newgetopt.pl"; 

  ##################################################################
 ####                                                            ####
####            Part 0: User-defined options                      ####
 ####                                                            ####
  ##################################################################

# Set these to allow slink to find some outside commands
$cmd_uname = '/usr/bin/uname'; 	# uname command returns hostname
$cmd_ps    = '/usr/bin/ps'; 	# ps command to check lock status

# Set these to indicate where control and output files live
# $opt_root = "/home/couch/utils/slink/src"; 	# testing root
$opt_root = "/loc"; 	     # root of tree where config files live
$opt_confile = "slink.conf"; # input: master configuration file
$opt_newfile = "slink.new";  # output: new links slink didn't make
$opt_logfile = "slink.log";  # output: actions taken
$opt_errfile = "slink.err";  # output: errors encountered
$opt_mapfile = "slink.map";  # i/o: map of all links
$opt_lokfile = "slink.pid";  # i/o: lockfile

# set this to a list of absolute paths that we should not expand links into. 
# This avoids problems with the automounter, which uses symbolic links as 
# virtual mounts. E.g. if /g is automounted, then /g -> /tmp_mnt/g, 
# but if /groups -> /g, slink should NOT expand this to /groups -> /tmp_mnt/g
# Some people have several automount hierarchies so I made it a list. 
# In our environment /local is usually a link to /loc/SLINK, which
# shouldn't be resolved either. 

@opt_dontresolve = ('/tmp_mnt'); 

# set this to a list of hosts on which it is permissible to run slink
# if this is empty, slink can be run anywhere. 

# @opt_slinkhosts = ('allegro'); 
@opt_slinkhosts = (); 

# set this to the umask to use in creating directories in the image tree. 
# For us, all image trees are preset to mode 0775, g+s, group staff, 
# so that subdirectories are also group staff. 

$opt_umask = 002; 

# set this to the mode you want on created directories. 

$opt_dirmode = 0775;

# set this to 1 to disable instance locking
# instance locking is important if you have several people 
# with privileges to run slink. Locking is file-based.

$opt_nolock = 0;	# override locking mechanism

  ##################################################################
 ####                                                            ####
####            Part 1: Main SLINK Program                        ####
 ####                                                            ####
  ##################################################################

# You should not have to modify any further 
# lines in SLINK in normal usage. 

# these flags are set by various command line options. 
$opt_debug    = 0; 	# 1 to enable debugging writes
$opt_verbose  = 0; 	# print verbose messages
$opt_link     = 0; 	# force an unlink not in the configuration file
$opt_unlink   = 0; 	# force a link not in the configuration file
$opt_clean    = 0; 	# delete links that point nowhere. 
$opt_condense = 0; 	# remove redundant directories. 
$opt_check    = 0; 	# print info about non-slink links and files. 
$opt_remap    = 0; 	# don't read mapfile initially.
$opt_nomap    = 0; 	# don't use or update mapfile. 
$opt_quiet    = 0; 	# 1 means don't write errors to controlling terminal. 
$opt_help     = 0; 	# print help and exit.

# default match keys for configuration file operations are empty
$opt_imagematch = ''; 	# match this pattern in link tree
$opt_targtmatch = ''; 	# match this pattern in source tree
$opt_modelmatch = ''; 	# match this pattern for model

# mask to use when creating files
umask $opt_umask;

######################################################################
# check for proper host to run upon 
######################################################################

if (!&slinkhosts) {
    print STDERR "slink: please make configuration runs ONLY on hosts:\n";
    print STDERR "@opt_slinkhosts\n"; 
    print STDERR "slink: exiting!\n"; 
    exit 1; 
}

######################################################################
# process arguments and determine what to do during this invocation 
######################################################################

sub help {
    print STDERR "SLINK USAGE:\n"; 
    print STDERR "slink [options] [<target_pat> [<image_pat> [<protection_pat>]]]\n";
    print STDERR "  makes links from configuration file matching the given patterns\n"; 
    print STDERR "slink -condense [options] [<target_pat> [<image_pat> [<protection_pat>]]]\n";
    print STDERR "  Condense image tree by removing redundant directories\n"; 
    print STDERR "slink -link [options] <target_name> <image_name> [<protection_model>]\n"; 
    print STDERR "  Forces creation of a slink not in the configuration file\n"; 
    print STDERR "slink -unlink [options] <target_name> <image_name> [<protection_model>]\n"; 
    print STDERR "  Forces deletion of a slink not in the configuration file\n"; 
    print STDERR "slink -clean [options] <image_name> [<image_name>...]\n"; 
    print STDERR "  Clean image tree by removing images to nonexistent nodes\n"; 
    print STDERR "slink -check [options] <image_name> [<image_name>...]\n"; 
    print STDERR "  check for possible image tree corruption\n"; 
    print STDERR "slink -help\n"; 
    print STDERR "  print this message only\n"; 
    print STDERR "OPTIONS:\n"; 
    print STDERR "  -verbose: print verbose description of actions.\n"; 
    print STDERR "  -quiet: don't echo errors to controlling terminal.\n"; 
    print STDERR "  -debug: print debugging trace\n"; 
    print STDERR "  -nolock: don't lock out multiple instances\n"; 
    print STDERR "  -nomap: don't read or write mapfile\n"; 
    print STDERR "  -remap: don't read mapfile initially\n"; 
    print STDERR "  -root <rootdirname>: specify a prefix for file names\n"; 
    print STDERR "  -confile <confilename>: specify a new configuration file.\n"; 
    print STDERR "  -errfile <errfilename>: specify a new error file.\n"; 
    print STDERR "  -logfile <logfilename>: specify a new log file.\n"; 
    print STDERR "  -lokfile <lokfilename>: specify a new lock file.\n"; 
    print STDERR "  -newfile <newfilename>: specify a new `new link' file.\n"; 
}

# get options as full names 
if (!&NGetOpt(
    '-',		# options start with -
    'clean',		# clean up non-existant links in specified trees
    'condense',		# condense image trees according to patterns
    'confile=s', 	# configuration file
    'errfile=s',	# error file
    'debug',		# print debugging traces
    'help',		# print a help message
    'link',		# create a link not in the config file
    'lokfile=s',	# lock file
    'logfile=s',	# log file
    'newfile=s',	# new links
    'nolock',		# don't use lockfile to lock out multiple instances.
    'nomap',		# don't use mapfile for read or write.
    'quiet',		# don't echo errors to the controlling terminal.
    'remap',		# don't read the mapfile before starting.
    'root=s',		# define root file
    'check', 		# check on corruption of link trees. 
    'unlink',		# delete a link not in the config file
    'verbose'		# print a verbose log on stderr. 
)) { &help; &shutdown; }

$opt_confile = &absolutize($opt_confile,$opt_root); 
$opt_newfile = &absolutize($opt_newfile,$opt_root); 
$opt_logfile = &absolutize($opt_logfile,$opt_root); 
$opt_errfile = &absolutize($opt_errfile,$opt_root); 
$opt_mapfile = &absolutize($opt_mapfile,$opt_root); 
$opt_lokfile = &absolutize($opt_lokfile,$opt_root); 

if ($opt_verbose) {
    &log_opt('clean',   $opt_clean   ); 
    &log_opt('condense',$opt_condense); 
    &log_opt('confile', $opt_confile ); 
    &log_opt('errfile', $opt_errfile ); 
    &log_opt('debug',   $opt_debug   ); 
    &log_opt('help',    $opt_help    ); 
    &log_opt('link',    $opt_link    ); 
    &log_opt('lokfile', $opt_lokfile ); 
    &log_opt('logfile', $opt_logfile ); 
    &log_opt('newfile', $opt_newfile ); 
    &log_opt('nolock',  $opt_nolock  ); 
    &log_opt('nomap',   $opt_nomap   ); 
    &log_opt('quiet',   $opt_quiet   ); 
    &log_opt('check',   $opt_check   ); 
    &log_opt('remap',   $opt_remap   ); 
    &log_opt('root',    $opt_root    ); 
    &log_opt('unlink',  $opt_unlink  ); 
    &log_opt('verbose', $opt_verbose ); 
    &log_verbose("argv=@ARGV"); 
}

# print a single option in human-readable form
sub log_opt {
   local($opt,$value)=@_; 
   $value = "[undefined]" if (! defined ($value)); 
   &log_verbose("$opt=$value"); 
}

# check for conflicts 
if ($opt_report + $opt_clean + $opt_condense 
  + $opt_link + $opt_unlink + $opt_help > 1) {
    print STDERR "slink: conflicting actions specified!\n"; 
    &help; exit(1); 
}

if (! -d $opt_root) {
    print STDERR "slink: $opt_root is not a directory!\n"; 
    &help; exit(1); 
}

# display help message and quit if asked. 
if ($opt_help) { &help; exit(1); } 

# lock out other instances of slink  
&set_lock if ! $opt_nolock; 

# start up logging in case later functions cause errors 
&open_logs; 

# dispatch subtask
if ($opt_check)       { &implement_check; } 
elsif ($opt_clean)    {	&implement_clean; } 
elsif ($opt_unlink)   { &implement_forced_unlink; } 
elsif ($opt_link)     { &implement_forced_link; } 
elsif ($opt_condense) { &implement_condense; } 
else                  { &implement_config; } 

# clear lock at the end of execution 
&clear_lock if ! $opt_nolock; 
exit(0); 

  ##################################################################
 ####                                                            ####
####            Part 2: Main SLINK Subroutines                    ####
 ####                                                            ####
  ##################################################################

######################################################################
#  implement a configuration change
######################################################################

sub implement_config {
    if (@ARGV>3) {
	print STDERR "slink: expecting at most three arguments!\n"; 
	&help; 
	&shutdown; 
    }
    ($opt_targtmatch,$opt_imagematch,$opt_modelmatch) = @ARGV; 
    (-r $opt_confile) || &shutdie ("cannot read $opt_confile"); 

    # initial working directories are / for link source, 
    #  prefix of configuration file for link target. 
    @cwds = (&path_prefix($opt_confile),'/'); 

    # if a clean link of the whole tree, warn user
    if ($opt_targtmatch eq '' && $opt_imagematch eq '') {
    	print STDERR "slink: link whole tree. This will take awhile.\n"; 
    }

    &map_read; 	
    &link_conf($opt_confile,@cwds,'relink'); 
    &map_close;
}

######################################################################
#  implement a condensing operation on the configuration file. 
######################################################################

sub implement_condense {
    if (@ARGV>3) {
	print STDERR "slink: expecting at most three arguments!\n"; 
	&help; 
	&shutdown; 
    }
    ($opt_targtmatch,$opt_imagematch,$opt_modelmatch) = @ARGV; 
    (-r $opt_confile) || &shutdie ("cannot read $opt_confile"); 

    # initial working directories are / for link source, 
    #  prefix of configuration file for link target. 
    @cwds = (&path_prefix($opt_confile),'/'); 

    # if a clean link of the whole tree, warn user
    if ($opt_targtmatch eq '' && $opt_imagematch eq '') {
    	print STDERR "slink: condense whole tree. This takes awhile.\n"; 
    }

    &map_read; 	
    &condense_conf($opt_confile,@cwds,'redirect'); 
    &map_close; 
}

######################################################################
#  implement a forced link not in the configuration file. 
######################################################################

sub implement_forced_link {
    if (@ARGV<2 || @ARGV>3) {
	print STDERR "slink: to force a link, you must specify\n";
	print STDERR "a sourcename, a linkname, and an optional storage model!\n";
	&help; 
	&shutdown; 
    }

    # first argument is link source, second argument is target
    ($targt,$image,$model) = @ARGV; 
    $targt = &absolutize($targt); 
    $image = &absolutize($image); 

    # actually make links
    &map_read; 
    &link_node($targt,$image,$model);
    &map_close;
} 

######################################################################
#  implement a forced unlink not in the configuration file. 
######################################################################

sub implement_forced_unlink {
    if (@ARGV<2 || @ARGV>3) {
	print STDERR "slink: to force an unlink, you must specify\n";
	print STDERR "a sourcename, a linkname, and an optional storage model!\n";
	&help; 
	&shutdown; 
    }

    # first argument is link source, second argument is target
    ($targt,$image,$model) = @ARGV; 
    $targt = &absolutize($targt); 
    $image = &absolutize($image); 

    # actually make links
    &map_read;
    &unlink_node($targt,$image,$model);	# unlink a single node
    &map_close; 			# write out the map
} 

######################################################################
#  implement a check of possible filesystem corruption 
######################################################################

sub implement_check {
    &map_read; 
    open (NEW, ">$opt_newfile") || &shutdie ("can't write to $opt_newfile: $!"); 
    foreach $tree (@ARGV) {
	$tree = &absolutize($tree); 
	&log_verbose("scanning $tree..."); 
	&unravel_node($tree); 
    }
    &map_close; 
}

######################################################################
#  clean a filesystem of invalid links that point nowhere
######################################################################

sub implement_clean {
    &map_read; 
    foreach $tree (@ARGV) {
	$tree = &absolutize($tree); 
	&log_verbose("cleaning $tree..."); 
	&clean_node($tree,'relink'); 
    }
    &map_close; 
}

  ##################################################################
 ####                                                            ####
####            Part 3: forming and destroying slinks             ####
 ####                                                            ####
  ##################################################################

######################################################################
# Form slinks from a configuration file; 
# descend into subfiles as necessary. 
# Preconditions:
#  $opt_confile: name of a configuration file to  
#   be processed, which can be either relative 
#   or absolute				 
#  $targtcwd: prefix for relative targets:  	 
#   this is appended to relative addresses   
#   in the first (target) field of the 	 
#   included file. 				 
#  $imagecwd: prefix for relative image 	 
#   locations: this is appended to relative  
#   addresses in the second (image) field of  
#   the included file. 			 
#  $imagemodel: image model for subframes	 
#  Global variables that affect this include:  
#   $opt_targtmatch: target match pattern	 
#   $opt_imagematch: image match pattern 	 
#   $opt_modelmatch: model match pattern 	 
#  LOG and ERRORS are open file descriptors.
#  %map is initialized to describe current link structure. 
# Postconditions: 
# Either 
#  the configuration file exists, 
#  slinks specified in the files are implemented if feasible, 
#  errors are noted in ERRORS, 
#  structural changes are described in the LOG, 
#  %map is modified to reflect changes in link structure,
#  and the return value is 1. 
# Or 
#  the configuration file doesn't exist, 
#  and the return value is 0. 
######################################################################

sub link_conf {
    local($opt_confile,$targtcwd,$imagecwd,$imagemodel) = @_; 
    &log_debug("link_conf($opt_confile,$targtcwd,$imagecwd,$imagemodel)"); 

    &log_verbose("Forming slinks from file $opt_confile");
    &log_verbose("Target working directory is $targtcwd"); 
    &log_verbose("Image  working directory is $imagecwd"); 
    &log_verbose("Default protection model is $imagemodel"); 

    if (! -e $opt_confile) {
	return &log_error("$opt_confile doesn't exist -- ignoring!"); 
    } elsif (! -f $opt_confile) {
	return &log_error("$opt_confile isn't a file -- ignoring!"); 
    } elsif (! -r $opt_confile) {
	return &log_error("$opt_confile is unreadable -- ignoring!"); 
    }

    # open and read link file to determine what to do
    open(CONF,"<$opt_confile") 
	|| return &log_error("can't open $opt_confile: $!"); 
    local (@conflines) = <CONF>; 
    local ($conflineno) = 0; 
    local ($confline) = ''; 

    # process each line in order
    foreach $confline (@conflines) {
	$conflineno++; 
	next if $confline =~ /^[ \t]*$/ || $confline =~ /^[ \t]*#/; 
	local (@confline) = split(/[ \t\n]+/,$confline); 
	shift @confline if $confline[0] eq ''; 

	# source a subfile in appropriate context
	if ($confline[0] =~ /^[+]/) {
	
	    local($newconf,$newtargtcwd,$newimagecwd,$newimagemodel)=@confline;
	    $newconf =~ s/^[+]//; 

	    # if file is not '', not absolute, then make absolute 
	    $newconf = $targtcwd . '/' . $newconf 
		if ($newconf ne '' && $newconf !~ /^\//);

	    # get a new current directory list to manipulate
	    if ($newtargtcwd =~ /^\//) {	# absolute path
		# just leave it alone
	    } elsif ($newtargtcwd eq '"') {	# leave alone
		$newtargtcwd = $targtcwd; 
	    } else {				# relative to current
		$newtargtcwd = &truename($targtcwd . '/' . $newtargtcwd);
	    }
	    # warn user of possibly bogus references 
	    if ($newtargtcwd ne '' && $newtargtcwd !~ /^\//) {
		&log_cerror("target prefix is RELATIVE $newtargtcwd\n (so relative target nodes may be bogus)"); 
	    }

	    # get a new current directory list to manipulate
	    if ($newimagecwd =~ /^\//) {		# absolute path
		# just leave it alone
	    } elsif ($newimagecwd eq '"') {	# leave alone
		$newimagecwd = $imagecwd; 
	    } else {				# relative to current
		$newimagecwd = $imagecwd . '/' . $newimagecwd;
	    }
	    # warn user of possibly bogus references 
	    if ($newimagecwd ne '' && $newimagecwd !~ /^\//) {
		&log_cerror("image prefix is RELATIVE $newimagecwd\n (so relative image nodes may be bogus)\n"); 
	    }

	    # determine the image model to use: 
	    #   protect: don't change any existing links
	    #   relink: only change links, not files. 
	    #   redirect: change directories back to links
	    # 	replace: replace intervening files. 
	    if ($newimagemodel eq 'protect'	# protect all
	     || $newimagemodel eq 'relink'	# destroy links
	     || $newimagemodel eq 'redirect'	# destroy links, directories.
	     || $newimagemodel eq 'replace') {	# destroy links, directories, files. 
		# just leave it alone
	    } elsif ($newimagemodel eq '"'
		  || $newimagemodel eq '' ) {     # leave alone
		$newimagemodel = $imagemodel;
	    } else {
		&log_cerror("unknown image model $newimagemodel"); 
		$newimagemodel = $imagemodel; 
	    }

	    # now cwds are correct -> recurse
	    if ($newconf ne '') {
		if (! &link_conf($newconf,$newtargtcwd,
			 	 $newimagecwd,$newimagemodel)) {
		    &log_cerror("previous error(s) occurred during this delegation."); 
		} 
	    } else {
		# a + by itself at beginning of a line means relativize 
		# current directory settings with respect to listed 
		# directories WITHOUT including a file to do so
		($targtcwd,$imagecwd,$imagemodel) 
		  = ($newtargtcwd,$newimagecwd,$newimagemodel); 
	    }
	} elsif ($confline[0] eq '!') {
	    # link deletion request: this is like a link creation 
	    # request except that it undoes rather than makes a link
	    local ($dummy,$targt,$image,$model) = @confline; 
	    $targt = $targtcwd . '/' . $targt if ($targt  !~ /^\//) ;
	    $image = $imagecwd . '/' . $image if ($image !~ /^\//) ;
	    $model = $imagemodel if $model eq ''; 
	    if (-e $targt) {
		&unlink_node($targt,$image,$model)
		    if index($targt,$opt_targtmatch)>=0
		    && index($image,$opt_imagematch)>=0
		    && index($model,$opt_modelmatch)>=0; 
	    } else {
		&log_cerror("$targt doesn't exist -- ignoring line");
	    }
	} else {
	    # if first field doesn't start with a '+' or '!', then this is a
       	    # normal link request, just link from the second pathname 
	    # to the first pathname; resolve relative pathnames
	    local ($targt,$image,$model) = @confline; 
	    $targt = $targtcwd . '/' . $targt if ($targt  !~ /^\//) ;
	    $image = $imagecwd . '/' . $image if ($image !~ /^\//) ;
	    $model = $imagemodel if $model eq ''; 
	    if (-e $targt) {
		&link_node($targt,$image,$model)
		    if index($targt,$opt_targtmatch)>=0
		    && index($image,$opt_imagematch)>=0
		    && index($model,$opt_modelmatch)>=0; 
	    } else {
		&log_cerror("$targt doesn't exist -- ignoring line");
	    }
	} 
    }
    return 1; 	# found configuration file OK
}

######################################################################
# Link $image to $targt, recording and correcting existing incorrect 
# links.  When encountering directories in source,
# copy directory structure recursively.	
# Preconditions: 
#  $targt: target of the slink
#  $image: image of the target.
#  $model: protection model
#   protect: can't change anything that already exists
#   relink: can change links into other links, files, or directories
#   redirect: can change directories into links or files. 
#   replace: can change files into links or directories. 
#  LOG and ERRORS are open file descriptors
#  %map is initialized to describe current link structure. 
# Postconditions: 
# Either:
#  the link is made, 
#  structural changes are described in the LOG, 
#  %map 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 ERRORS, 
#  structural changes are described in the LOG, 
#  %map is modified to reflect changes in link structure,
#  and the return value is 0. 
######################################################################

sub link_node {
    local($targt,$image,$model) = @_; 
    &log_debug("link_node($targt,$image,$model)"); 

    &log_verbose("trying to link $image => $targt (model $model)"); 

    # note: you don't need to be able to read a file to make it available
    (-e $targt) || return &log_error("ignoring nonexistant target $targt"); 
    local ($trutarg) = &truename($targt); 

    &log_verbose("linking $image => $trutarg (model $model)"); 

    if (&isame($image,$trutarg)) {
	&map_add($trutarg,$image) if -l $image; 
 	return 1; 
    } elsif (-d $image && -d $trutarg) {	# both are directories
	return &link_directory($trutarg,$image,$model); 
    } else {				# one isn't a directory
	&make_path_to($image,$model) || return 0; 
	&remove_node($image,$model) || return 0 if -e $image || -l $image; 
	&make_link ($trutarg,$image) || return 0; 
	return 1; 
    }
}

######################################################################
# make links between two parallel directories
# Preconditions: 
#  $targt: target of the slink, must be a directory. 
#  $image: image of the target, must be a directory. 
#  $model: protection model
#   protect: can't change anything that already exists
#   relink: can change links into other links, files, or directories
#   redirect: can change directories into links or files. 
#   replace: can change files into links or directories. 
#  LOG and ERRORS are open file descriptors
#  %map is initialized to describe current link structure. 
# Postconditions:
# Either:
#  the directories can be linked, 
#  structural changes are described in the LOG, 
#  %map is modified to reflect changes in link structure,
#  and the return value is 1, 
# Or
#  the directories cannot be linked due to physical or model problems, 
#  the reasons are printed in ERRORS, 
#  structural changes are described in the LOG, 
#  %map is modified to reflect changes in link structure,
#  and the return value is 0. 
######################################################################

sub link_directory {
    local ($targt,$image,$model) = @_;
    &log_debug("link_directory($targt,$image,$model)");

    opendir(DIR,"$targt") 
	|| return &log_error("can't open directory $targt: $!"); 
    local($works)=1; 
    local($entry); 
    foreach $entry (readdir DIR) {
	next if ($entry eq '.' || $entry eq '..'); 
	&link_node("$targt/$entry","$image/$entry",$model) 
	    || ($works=0);
    }
    return $works; 
}

######################################################################
# remove links between two nodes, wherever they are
# Preconditions: 
#  $targt: target of the slink
#  $image: image of the target.
#  $model: protection model
#   protect: can't change anything that already exists
#   relink: can change links into other links, files, or directories
#   redirect: can change directories into links or files. 
#   replace: can change files into links or directories. 
#  LOG and ERRORS are open file descriptors
#  %map is initialized to describe current link structure. 
# Postconditions: 
# Either:
#  the nodes can be unlinked or are already unlinked, 
#  structural changes are described in the LOG, 
#  %map 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 printed in ERRORS, 
#  structural changes are described in the LOG, 
#  %map is modified to reflect changes in link structure,
#  and the return value is 0. 
######################################################################

sub unlink_node {
    local($targt,$image,$model) = @_; 
    &log_debug("unlink_node($targt,$image,$model)"); 

    &log_verbose("trying to unlink $image !=> $targt (model $model)"); 

    # note: you don't have to be able to read a file to make it available 
    (-e $targt) || return &log_error("ignoring nonexistant target $targt"); 
    local ($trutarg) = &truename($targt); 

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

    &log_verbose("unlinking $image !=> $targt (model $model)"); 

    # 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,$trutarg); 
	&remove_node($image,$model) || return 0; 
	return 1; 

    # if the node is a directory, then try double descent
    } elsif (-d $image && -d $trutarg) {	
	return &unlink_directory($trutarg,$image,$model); 
    } 

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

######################################################################
# remove links between two parallel directories
# Preconditions: 
#  $targt: target of the slink, must be a directory. 
#  $image: image of the target, must be a directory. 
#  $model: protection model,  must be a directory. 
#   protect: can't change anything that already exists
#   relink: can change links into other links, files, or directories
#   redirect: can change directories into links or files. 
#   replace: can change files into links or directories. 
#  LOG and ERRORS are open file descriptors
#  %map is initialized to describe current link structure. 
# Postconditions: 
# Either
#  the directories can be unlinked or are already unlinked, 
#  structural changes are described in the LOG, 
#  %map is modified to reflect changes in link structure,
#  and the return value is 1, 
# Or
#  we cannot unlink the directories due to physical or model problems, 
#  the reason is printed in ERRORS, 
#  structural changes are described in the LOG, 
#  %map is modified to reflect changes in link structure,
#  and the return value is 0. 
######################################################################

sub unlink_directory {
    local ($targt,$image,$model) = @_;
    &log_debug("unlink_directory($targt,$image,$model)");

    opendir(DIR,"$targt") 
	|| return &log_error("can't open directory $targt: $!"); 
    local($works)=1; 
    local($entry); 
    foreach $entry (readdir DIR) {
	next if ($entry eq '.' || $entry eq '..'); 
	&unlink_node("$targt/$entry","$image/$entry",$model) 
	    || ($works=0);
    }
    return $works; 
}

  ##################################################################
 ####                                                            ####
####            Part 4: Condensing confluent structures           ####
 ####                                                            ####
  ##################################################################

######################################################################
# Condense links in a configuration file         
# Interpret a configuration file slink.conf and  
# descend into subfiles as necessary 		  
# Preconditions: arguments are 		  
#  $opt_confile: name of a configuration file to   
#   be processed, which can be either relative 
#   or absolute				  
#  $targtcwd: prefix for relative targets:   	  
#   this is appended to relative addresses     
#   in the first (target) field of the 	  
#   included file. 				  
#  $imagecwd: prefix for relative image 	  
#   locations: this is appended to relative    
#   addresses in the second (image) field of   
#   the included file.  			  
#  $imagemodel: image model for subframes	  
#  Global variables that affect this include:   
#   $opt_targtmatch: target match pattern	  
#   $opt_imagematch: image match pattern 	  
#   $opt_modelmatch: model match pattern 	  
#  LOG and ERRORS are open file descriptors.
#  %map is initialized to describe current link structure. 
# Postconditions: 
# Either 
#  the configuration file exists, 
#  slinks specified in the files are condensed if feasible, 
#  errors are noted in ERRORS, 
#  structural changes are described in the LOG, 
#  %map is modified to reflect changes in link structure,
#  and the return value is 1. 
# Or 
#  the configuration file doesn't exist, 
#  and the return value is 0. 
######################################################################

sub condense_conf {
    local($opt_confile,$targtcwd,$imagecwd,$imagemodel) = @_; 
    &log_debug("condense_conf($opt_confile,$targtcwd,$imagecwd,$imagemodel)"); 

    &log_verbose("Condensing slinks from file $opt_confile");
    &log_verbose("Target working directory is $targtcwd"); 
    &log_verbose("Image  working directory is $imagecwd"); 
    &log_verbose("Default protection model is $imagemodel"); 

    if (! -e $opt_confile) {
	return &log_error("$opt_confile doesn't exist -- ignoring!"); 
    } elsif (! -f $opt_confile) {
	return &log_error("$opt_confile isn't a file -- ignoring!"); 
    } elsif (! -r $opt_confile) {
	return &log_error("$opt_confile is unreadable -- ignoring!"); 
    }

    # open and read link file to determine what to do
    open(CONF,"<$opt_confile") 
	|| return &log_error("can't open $opt_confile: $!"); 
    local (@conflines) = <CONF>; 
    local ($conflineno) = 0; 
    local ($confline) = ''; 

    # process each line in order
    foreach $confline (@conflines) {
	$conflineno++; 
	next if $confline =~ /^[ \t]*$/ || $confline =~ /^[ \t]*#/; 
	local (@confline) = split(/[ \t\n]+/,$confline); 
	shift @confline if $confline[0] eq ''; 

	# source a subfile in appropriate context
	if ($confline[0] =~ /^[+]/) {
	
	    local($newconf,$newtargtcwd,$newimagecwd,$newimagemodel)=@confline;
	    $newconf =~ s/^[+]//; 

	    # if file is not '', not absolute, then make absolute 
	    $newconf = $targtcwd . '/' . $newconf 
		if ($newconf ne '' && $newconf !~ /^\//);

	    # get a new current directory list to manipulate
	    if ($newtargtcwd =~ /^\//) {	# absolute path
		# just leave it alone
	    } elsif ($newtargtcwd eq '"') {	# leave alone
		$newtargtcwd = $targtcwd; 
	    } else {				# relative to current
		$newtargtcwd = &truename($targtcwd . '/' . $newtargtcwd);
	    }
	    # warn user of possibly bogus references 
	    if ($newtargtcwd ne '' && $newtargtcwd !~ /^\//) {
		&log_cerror("target prefix is RELATIVE $newtargtcwd\n (so relative target nodes may be bogus)"); 
	    }

	    # get a new current directory list to manipulate
	    if ($newimagecwd =~ /^\//) {		# absolute path
		# just leave it alone
	    } elsif ($newimagecwd eq '"') {	# leave alone
		$newimagecwd = $imagecwd; 
	    } else {				# relative to current
		$newimagecwd = $imagecwd . '/' . $newimagecwd;
	    }
	    # warn user of possibly bogus references 
	    if ($newimagecwd ne '' && $newimagecwd !~ /^\//) {
		&log_cerror("image prefix is RELATIVE $newimagecwd\n (so relative image nodes may be bogus)"); 
	    }

	    # determine the image model to use: 
	    #   protect: don't change any existing links
	    #   relink: only change links, not files. 
	    #   redirect: change directories back to links
	    # 	replace: replace intervening files. 
	    if ($newimagemodel eq 'protect'
	     || $newimagemodel eq 'relink'
	     || $newimagemodel eq 'redirect'
	     || $newimagemodel eq 'replace') {
		# just leave it alone
	    } elsif ($newimagemodel eq '"' 
		  || $newimagemodel eq '') {     
		# default to old
		$newimagemodel = $imagemodel;
	    } else {
		&log_cerror("unknown image model $newimagemodel"); 
		$newimagemodel = $imagemodel; 
	    }

	    # now cwds are correct -> recurse
	    if ($newconf ne '') {
		if (! &condense_conf($newconf,$newtargtcwd,
				     $newimagecwd,$newimagemodel)) {
		    &log_error("previous error(s) occurred during this delegation."); 
		} 
	    } else {
		# a + by itself at beginning of a line means relativize 
		# current directory settings with respect to listed 
		# directories WITHOUT including a file to do so
		($targtcwd,$imagecwd,$imagemodel) 
		  = ($newtargtcwd,$newimagecwd,$newimagemodel); 
	    }
	} elsif ($confline[0] eq '!') {
	    # link deletion request: this is like a link creation 
	    # request except that it undoes rather than makes a link
	    local ($dummy,$targt,$image,$model) = @confline; 
	    $targt = $targtcwd . '/' . $targt if ($targt  !~ /^\//) ;
	    $image = $imagecwd . '/' . $image if ($image !~ /^\//) ;
	    $model = $imagemodel if $model eq ''; 
	    if (-e $targt) {
		&unlink_node($targt,$image,$model)
		    if index($targt,$opt_targtmatch)>=0
		    && index($image,$opt_imagematch)>=0
		    && index($model,$opt_modelmatch)>=0; 
	    } else {
		&log_cerror("$targt doesn't exist -- ignoring line");
	    }
	} else {
	    # if first field doesn't start with a '+' or '!', then this is a
       	    # normal link request, just link from the second pathname 
	    # to the first pathname; resolve relative pathnames
	    local ($targt,$image,$model) = @confline; 
	    $targt = $targtcwd . '/' . $targt if ($targt  !~ /^\//) ;
	    $image = $imagecwd . '/' . $image if ($image !~ /^\//) ;
	    $model = $imagemodel if $model eq ''; 
	    if (-e $targt) {
		&condense_node($targt,$image,$model)
		    if index($targt,$opt_targtmatch)>=0
		    && index($image,$opt_imagematch)>=0
		    && index($model,$opt_modelmatch)>=0; 
	    } else {
		&log_cerror("$targt doesn't exist -- ignoring line");
	    }
	} 
    }
    return 1; 	# found configuration file OK
}

#####################################################################
# condensing routine:
#  if a link directory is exactly equivalent to a target 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: 
#  $targt: target of the slink. 
#  $image: image of the target.
#  $model: protection model.
#   protect: can't change anything that already exists
#   relink: can change links into other links, files, or directories
#   redirect: can change directories into links or files. 
#   replace: can change files into links or directories. 
#  LOG and ERRORS are open file descriptors
#  %map is initialized to describe current link structure. 
# Postconditions: 
# Either:
#  the image is condensed, 
#  structural changes are described in the LOG, 
#  %map 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, 
#  significant reasons are printed in ERRORS, 
#  structural changes are described in the LOG, 
#  %map is modified to reflect changes in link structure,
#  and the return value is 0. 
#####################################################################

sub condense_node {
    local ($targt, $image, $model) = @_; 
    &log_debug("condense_node($targt,$image,$model)");
    &log_verbose("condensing $image => $targt (model $model)"); 

    # check whether files are identical
    if ($targt eq $image) {
	# &log_debug("condense: $targt is identical with $image"); 
	# &log_debug("condense: $targt === $image"); 
	return 0; 		# oops, identical files, one copy, don't delete
    } elsif (-l $image) {
	local ($oldtargt) = readlink($image); 
	local ($abstargt) = &absolutize($oldtargt,&path_prefix($image)); 

	if (! -e $abstargt) {
	    &remove_node($image, $model); 
	    return 1; 
	} elsif (&isame($targt, $image)) {
	    # &log_debug("condense: $targt and $image are equivalent"); 
	    # &log_debug("condense: $targt =.= $image"); 
	    return 1;		# image file is same as target
 	} else {
	    # &log_debug("condense: $image is not a symlink to $targt"); 
	    # &log_debug("condense: $targt =!= $image"); 
	    return 0; 		# oops, not a link
 	}
    } elsif (-d $image) {
        if (! -d $targt) {
	    # &log_debug("condense: $image is a directory and $targt isn't"); 
	    # &log_debug("condense: $targt =!= $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. 
        local ($success) = &condense_directory($targt,$image,$model); 
        if ($success) { 
	    # &log_debug("condense: $targt =.= $image");
	    &remove_node($image,$model) || return 0; 
	    &make_link($targt,$image) || return 0; 
	    &log_mesg("condense directory $image into a link $image -> $targt"); 
	    return 1; 
        } else {
	    # &log_debug("condense: $targt =!= $image");
	    return 0; 
	}
    } else {		# there's a file in the image
	# &log_debug("condense: $image isn't a link or directory"); 
 	# &log_debug("condense: $targt =!= $image"); 
	return 0; 
    }
}

#####################################################################
# condense one pair of directories if possible
# head-recurse down the tree and try to condense lower levels first
# Preconditions: 
#  $targt: target of the slink, must be a directory
#  $image: image of the target, must be a directory
#  $model: protection model.
#   protect: can't change anything that already exists
#   relink: can change links into other links, files, or directories
#   redirect: can change directories into links or files. 
#   replace: can change files into links or directories. 
#  LOG and ERRORS are open file descriptors
#  %map is initialized to describe current link structure. 
# Postconditions: 
# Either:
#  the image is condensed, 
#  structural changes are described in the LOG, 
#  %map 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, 
#  significant reasons are printed in ERRORS, 
#  structural changes are described in the LOG, 
#  %map is modified to reflect changes in link structure,
#  and the return value is 0. 
#####################################################################

sub condense_directory {
    local($targt,$image,$model) = @_; 
    &log_debug("condense_directory($targt,$image,$model)");

    local($success) = 1; 

    # first scan the directory looking for things to coalesce. 
    opendir(DIR, $image)
	|| return &log_error("cannot open directory $image"); 
    local (@imagelist) = sort readdir(DIR);
    foreach $node (@imagelist) {
	next if ($node eq '.' || $node eq '..'); 
	if (!&condense_node("$targt/$node","$image/$node",$model)) {
	    $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 target, then return 1. 
    opendir(DIR, $targt)
	|| return &log_error("cannot open directory $targt"); 
    local (@targtlist) = sort readdir(DIR);

    # if not the same number of elements, then not confluent. 
    if (@targtlist != @imagelist) { 
	# &log_debug("condense: |$targt| and |$image| differ"); 
 	return 0; 
    } 

    # if not the same elements, then not confluent. 
    for ($i=0; $i<@targtlist; $i++) {
	if ($targtlist[$i] ne $imagelist[$i]) {
	    # &log_debug("condense: contents of $targt and $image differ"); 
	    return 0; 
	}
    }
    return 1; 
}

  ##################################################################
 ####                                                            ####
####            Part 5: Information gathering                     ####
 ####                                                            ####
  ##################################################################

######################################################################
# 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. 
#  $model: protection model for cleaning. 
#   protect: can't change anything that already exists
#   relink: can change links into other links, files, or directories
#   redirect: can change directories into links or files. 
#   replace: can change files into links or directories. 
#  LOG and ERRORS are open file descriptors.
#  %map is initialized to describe current link structure. 
# Postconditions: 
# Either: 
#  $node and its subtrees contain no nonexistant (dangling) links,
#  structural changes are described in the LOG, 
#  %map 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, 
#  reasons are printed in ERRORS, 
#  structural changes are described in the LOG, 
#  %map is modified to reflect changes in link structure,
#  and the return value is 0. 
######################################################################

sub clean_node {
    local ($node,$model) = @_; 
    &log_debug("clean_node($node,$model)"); 
    if (-l $node) {
	local ($oldtargt) = readlink($node); 
	local ($abstargt) = &absolutize($oldtargt,&path_prefix($node)); 
	return &remove_node($node,$model) if ! -e $abstargt; 
    } elsif (-d $node) {
	return &clean_directory($node,$model); 
    }
}

######################################################################
# for a given directory, remove links which point nowhere. 
######################################################################

sub clean_directory {
    local ($dir,$model) = @_; 
    local ($worked)=1;
    &log_debug("clean_directory($dir,$model)");
    opendir(DIR,"$dir") 
	|| return &log_error("can't open directory $dir: $!"); 
    local ($entry); 
    foreach $entry (readdir DIR) {
	next if ($entry eq '.'  || $entry eq '..'); 
	&clean_node($dir . '/' . $entry,$model) || ($worked = 0); 
    }
    return $worked; 
}

######################################################################
# 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. 
#  LOG, ERRORS, and NEW are open file descriptors.
#  %map is initialized to describe current link structure. 
# Postconditions: 
#  possible corruption is described on STDERR. 
#  links not made by slink are described in NEW. 
#  return value is 1 if no possible problems are reported, 
#  0 if some problems were found. 
######################################################################

sub unravel_node {
    local ($node) = @_; 
    &log_debug("unravel_node($node)"); 

    if (-l $node) {
	local ($oldtargt) = readlink($node); 
	local ($abstargt) = &absolutize($oldtargt,&path_prefix($node));
	if (! -e $abstargt) {
	    print STDERR "found dangling link $node -> $oldtargt\n";
	    return 0; 
	} else {
	    if (! &map_member($oldtargt,$node)) { 
		print STDERR "slink did not create $node -> $oldtargt\n"; 
		print NEW "$oldtargt $node\n";
	        return 0; 
  	    } else {
		return 1; 
	    }
        }
    } elsif (-d $node) {
	return &unravel_directory($node); 
    } else { 	# normal file in link tree!
	print STDERR "found a non-link, non-directory node $node\n"; 
	return 0; 
    }
}

######################################################################
# for a given directory, check whether links were created by SLINK
######################################################################

sub unravel_directory {
    local ($dir) = @_; 
    local ($worked) = 1; 
    &log_debug("unravel_directory($dir)");
    opendir(DIR,"$dir") 
        || return &log_error("can't open directory $dir: $!"); 
    local ($entry); 
    foreach $entry (readdir DIR) {
	next if ($entry eq '.'  || $entry eq '..'); 
	&unravel_node($dir . '/' . $entry) || ($worked = 0); 
    }
    return $worked; 
}

  ##################################################################
 ####                                                            ####
####            Part 6: Mapping of slink-created links            ####
 ####                                                            ####
  ##################################################################

######################################################################
#  mapping of links for error checking 
#  internally, a link is a list of all values it took during this run.
#  externally, a link is just the last value it took. 
#  map_write strips off all the other values, after map_check
#  reports errors in the configuration file. 
######################################################################

# return 1 if the given link is mapped, 0 otherwise

sub map_member {
    local($targt,$image) = @_; 
    local(@temp) = split(/[ \t]+/,$map{$image}); 
    for (local($i)=0; $i<=$#temp && $temp[$i] ne $targt; $i++) { }
    return 1 if ($i<=$#temp);
    return 0; 
}

# add a link to a map; make the added link
# the first one in the link list, and 
# eliminate duplicates. 

sub map_add {
    local($targt,$image) = @_; 
    &log_debug("map_add($image,$targt)"); 
    if ($map{$image} eq '') {
	$map{$image} = $targt; 
    } else {
	local(@temp) = split(/[ \t]+/,$map{$image}); 

	# if the link was deleted, undelete it
	shift(@temp) if $temp[0] eq ''; 

	# remove new value from list if it's there
	for (local($i)=0; $i<=$#temp && $temp[$i] ne $targt; $i++) { }
	if ($temp[$i] eq $targt) { splice(@temp,$i,1); }

	# new value is first value
	unshift(@temp,$targt); 

	# record the morass
	$map{$image} = join(' ',@temp); 
    }
}

# delete a mapped link from the link database
# this is only done if the link's target is 
# the $targt specified. 

sub map_del {
    local($targt,$image) = @_; 
    &log_debug("map_del($image,$targt)"); 
    local(@temp) = split(/[ \t]+/,$map{$image}); 
    if ($temp[0] eq $targt) {
	unshift(@temp,''); 
	$map{$image} = join(' ',@temp); 
    }
}

# write a map to a file. 
# only write principal targets, ignoring other targets
# that may have been used during a link run. 

sub map_write {
    &log_debug("map_write"); 
    open(MAP,">$opt_mapfile") 
	|| &shutdie ("can't write into $opt_mapfile: $!\n"); 
    while (local($key,$value) = each %map) {
	local(@value) = split(/[ \t]+/,$value); 
        print MAP "$key -> $value[0]\n" if $value[0] ne ''; 
    }
    close(MAP); 
}

# read a map for interim checking of sources
# include old map targets if they're in the current map. 

sub map_read {
    &log_debug("map_read"); 
    %map = (); 
    return if $opt_remap || $opt_nomap || ! -e $opt_mapfile; 
    open(MAP,"<$opt_mapfile") 
	|| &shutdie ("can't read from $opt_mapfile: $!\n"); 
    while (<MAP>) {
	next if /^[ \t]*$/ || /^[ \t]*#/; 
	local($key,$dummy,@value) = split; 
	$map{$key} = join(' ',@value); 
    }
    close(MAP); 
}

# check a map for duplicate sources

sub map_check {
    &log_debug("map_check"); 
    local (@dups) = (); 
    while (local($key,$value) = each %map) {
	local(@value) = split(/[ \t]+/,$value); 
	shift (@value) if $value[0] eq ''; 
	if (@value>1) {
	    print ERRORS "slink: $key has multiple sources:\n"; 
	    foreach (@value) {
		print ERRORS " -> $_\n"; 
	    }
	    push(@dups,$key); 
	}
    }
    return @dups; 
}

# close a map by writing it out and checking for errors. 

sub map_close {
    &log_debug("map_close"); 
    return if $opt_nomap; 
    &map_write; 		# write out the map
    @dups = &map_check; 	# check if map is multiple or not
    $dups = @dups; 		# number of keys
    if ($dups > 0) { 
	print STDERR "$dups duplicate sources found!\n"; 
	print STDERR "(see $opt_errfile for a list of errors)\n"; 
	return 0; 
    }
    return 1; 
}

  ##################################################################
 ####                                                            ####
####            Part 7: Special-purpose utilities                 ####
 ####                                                            ####
  ##################################################################

######################################################################
# make a link via a symlink call, but log the result in logfiles
# and the mapfile for future reference. 
# Preconditions: 
#  $target and $image are suitable for a symlink call. 
#  LOG and ERRORS are open file descriptors
#  %map is initialized to describe current link structure. 
# Postconditions: 
# Either
#  the link can be constructed, 
#  the link is described in the LOG,
#  %map is updated for the existence of the new link,
#  and the return value is 1. 
# Or
#  the link cannot be made, 
#  the reason is described in ERRORS. 
#  and the return value is 0. 
######################################################################

sub make_link {
    local ($target, $image) = @_; 
    &log_verbose("making link $image -> $target"); 
    symlink ($target,$image) 
	|| return &log_error("cannot link $image -> $target: $!");
    &log_mesg("make link $image -> $target"); 
    &map_add($target,$image);
    return 1; 
}

######################################################################
# make a directory via a mkdir call, and record the act in logfiles
# Preconditions: 
#  $dir and $mode are suitable for a mkdir call. 
#  LOG and ERRORS are open file descriptors.
# Postconditions: 
# Either
#  the directory is constructed, 
#  the act is described in LOG,
#  and the return value is 1. 
# Or
#  the directory cannot be constructed, 
#  the reason is described in ERRORS,
#  and the return value is 0. 
######################################################################

sub make_directory {
    local($dir,$mode)=@_; 
    &log_verbose("making directory $dir"); 
    mkdir($dir, $mode) 
	|| return &log_error("cannot make directory $dir: $!"); 
    &log_mesg("make directory $dir");
    return 1; 
}

######################################################################
# remove either a directory or other node according to a given
# modification model for the image tree.  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
#  $model is the storage model to obey
#   protect: can't change anything that already exists
#   relink: can change links into other links, files, or directories
#   redirect: can change directories into links or files. 
#   replace: can change files into links or directories. 
#  LOG and ERRORS are open file descriptors
#  %map is initialized to describe current link structure. 
# Postconditions: 
# Either 
#  $node is removed, 
#  structural changes are described in the LOG, 
#  %map 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 failure is described in ERRORS, 
#  structural changes are described in the LOG, 
#  %map is modified to reflect changes in link structure,
#  and the return value is 0. 
######################################################################

sub remove_node {
    local($node,$model)=@_; 
    &log_debug("remove_node($node,$model)");

    if (-l $node) {
	if (&can_relink($model)) {
	    local($oldtargt) = readlink($node); 
	    local($abstargt) = &absolutize($oldtargt,&path_prefix($node));

	    &log_verbose("removing link $node -> $oldtargt"); 
	    unlink($node)
	    	|| return &log_error("cannot remove link $node -> $oldtargt: $!"); 
	    if (-e $abstargt) {
		 &log_mesg("remove existing link $node -> $oldtargt"); 
	    } else {
		 &log_mesg("remove dangling link $node -> $oldtargt"); 
	    }
	    &map_del($oldtargt,$node);
	    return 1; 
	} else {
	    return &log_error("may not remove symlink $node (model '$model')"); 
	}
    } elsif (-d $node) {
	if (&can_redirect($model)) {

	    &log_verbose("removing contents of directory $node"); 
	    &remove_contents($node,$model) 
		|| return &log_error("cannot remove contents of $node"); 

	    &log_verbose("removing directory $node"); 
	    rmdir($node)
		|| return &log_error("cannot remove directory $node: $!");

	    return &log_mesg("remove directory $node"); 

	} else {
	    return &log_error("may not remove directory $node (model '$model')"); 
	}
    } elsif (-e $node) { # a regular file; I don't care what kind
	if (&can_replace($model)) {

	    &log_verbose("removing file $node"); 
	    unlink($node)
		|| return &log_error("cannot remove file $node: $!"); 
	    return &log_mesg("remove file $node"); 

	} else {
	    return &log_error("may not remove file $node (model '$model')"); 
	}
    }
    return 1; 
}

######################################################################
# recursively delete the contents of a directory, obeying a 
# storage model, but don't traverse any symbolic links. Models include:
# Preconditions: 
#  $dir is a directory to empty. This must be a directory. 
#  $model is a storage model to obey.
#   protect: can't change anything that already exists
#   relink: can change links into other links, files, or directories
#   redirect: can change directories into links or files. 
#   replace: can change files into links or directories. 
#  LOG and ERRORS are open file descriptors. 
#  %map is initialized to describe current link structure. 
# Postconditions: 
# Either
#  $dir is emptied, 
#  structural changes are described in the LOG, 
#  %map is modified to reflect changes in link structure,
#  and the return value is 1. 
# Or
#  $dir cannot be emptied because of model or physical protection, 
#  the reason is printed in ERRORS,
#  structural changes are described in the LOG, 
#  %map is modified to reflect changes in link structure,
#  and the return value is 0. 
######################################################################

sub remove_contents {
    local ($dir,$model) = @_;
    &log_debug("remove_contents($dir,$model)");

    opendir(DIR,"$dir") 
	|| return &log_error("cannot read directory $dir: $!"); 

    # remove all nodes from the directory according to the 
    # current modification model. return value is whether all worked. 
    local($worked)=1; 
    local($entry); 

    foreach $entry (readdir DIR) {
	next if ($entry eq '.' || $entry eq '..'); 
	&remove_node("$dir/$entry",$model) 
	    || ($worked=0); 
    }

    return $worked; 
}

######################################################################
# 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.
#  $model is a storage modification model to obey
#   protect: can't change anything that already exists
#   relink: can change links into other links, files, or directories
#   redirect: can change directories into links or files. 
#   replace: can change files into links or directories. 
#  LOG and ERRORS are open file descriptors
#  %map 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 in the LOG, 
#  %map 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 in ERRORS, 
#  structural changes are described in the LOG, 
#  %map is modified to reflect changes in link structure,
#  and the return value is 0. 
######################################################################

sub make_path_to {
    local($image,$model) = @_; 
    &log_debug("make_path_to($image,$model)"); 

    # compute all prefixes and mutate them into directories if possible
    local(@image) = split("/",$image); 
    local($i); 
    for ($i=1; $i<$#image; $i++) {
	local($path) = join("/",@image[0..$i]); 
	if (-l $path && -e $path) {
	    local($oldtargt)=readlink($path); 
	    if (!&dontresolve($oldtargt)) {	# don't brachiate automounts
		$abstargt = &absolutize($oldtargt,&path_prefix($path));
		&log_verbose("promoting $path -> $oldtargt from link to directory.");
		&remove_node($path,$model) || return 0; 
		&make_directory($path,$opt_dirmode) || return 0; 
		&link_directory($abstargt,$path,$model) || return 0; 
		&log_mesg("promote $path -> $oldtargt from link to directory.");
	    } else {
		&log_verbose("Skipping automount point $path"); 
	    }
	} elsif (! -d $path) {
	    &log_verbose("mutating $path into a directory.");
	    &remove_node($path,$model) || return 0; 
	    &make_directory($path,$opt_dirmode) || return 0;
	    &log_mesg("mutate $path into a directory.");
	}
    }
    return 1;
}

######################################################################
# model check routines tell whether it's permissible 
# to perform various operations on an image.  The 
# single argument is interpreted and the return 
# value tells whether you can do what you want.
######################################################################

sub can_relink {
    local($model) = @_; 
    return 1 if $model eq 'replace' 	# destroy links, directories, files.
	     || $model eq 'redirect' 	# destroy links, directories.
	     || $model eq 'relink' 	# destroy links
	     || $model eq ''; 		# same as relink
    return 0; 
}

sub can_redirect {
    local($model) = @_; 
    return 1 if $model eq 'replace' 	# destroy links, directories, files.
	     || $model eq 'redirect';	# destroy links, directories
    return 0; 
}

sub can_replace {
    local($model) = @_; 
    return 1 if $model eq 'replace'; 	# destroy files
    return 0; 
}

######################################################################
# logging routines write to predefined logfiles.
# a logfile must be open before calling each one.
######################################################################

# open logs so following routines will work. 

sub open_logs {
    $date = &ctime(time); chop $date; 

    open(LOG,">>$opt_logfile") 
      || &shutdie ("cannot open logfile $opt_logfile");
    &log_mesg("slink started by $ENV{'USER'} on $date"); 

    open(ERRORS,">>$opt_errfile") 
	|| &shutdie ("cannot open error file $opt_errfile: $!"); 
    print ERRORS "slink started on $date\n"; 
}

# normal message log indicates actions taken

sub log_mesg {
    local($message) = @_; 
    print LOG "$message\n"; 
    return 1; 
}

# verbose log indicates intent before doing something

sub log_verbose {
    local($message) = @_; 
    print STDERR "slink: $message\n" if $opt_verbose; 
    return 1; 
}

# debug logger tells about internal operations

sub log_debug {
    local ($message) = @_; 
    print STDERR "slink: $message\n" if $opt_debug; 
    return 1; 
}

# general error logger informs about errors
# Preconditions: 
#  ERRORS is an open file descriptor
#  $message is an error message. 
# Postconditions: 
#  $message appears in ERRORS

sub log_error {
    local ($message) = @_; 
    print ERRORS "$message\n"; 
    if (! $opt_quiet) {
	print STDERR "slink: $message\n";
    }
    return 0;
}

# informs user of configuration file errors, 
# showing the position of the offending line 
# in the configuration file. 
# Preconditions: variables $conflineno and $confline are in 
#  scope, usually as a result of calling this as a child 
#  of link_conf or condense_conf. (PERL is DYNAMICALLY scoped)
#  ERRORS is an open file descriptor
# Postconditions: the error is described in ERRORS along with the 
#  line in the configuration file that caused it. 

sub log_cerror {
    local ($message) = @_; 
    print ERRORS "file $opt_confile line $conflineno:\n"; 
    print ERRORS " line contents: $confline";
    print ERRORS " $message\n"; 
    if (! $opt_quiet) {
	print STDERR "slink: file $opt_confile line $conflineno:\n"; 
	print STDERR " line contents: $confline";
	print STDERR " $message\n"; 
    }
    return 0; 
}

######################################################################
# locking mechanism keeps two major slink
# instances from running at the same time.
######################################################################

sub set_lock {
    if (-e $opt_lokfile) {
	open(PIDFILE, "<$opt_lokfile") 
	    || die "Can't open $opt_lokfile for reading: $!\n";
	$_ = <PIDFILE>; chop $_; 
        close(PIDFILE); 
	($pid, $uid, $user, $predate) = split(/\t/, $_);
	$pidcheck = system("$cmd_ps -p $pid 1> /dev/null 2>&1");
	if (!$pidcheck) { 
	    print STDERR 
		"slink: already running!";
	    print STDERR 
		"slink: $user ($uid) started slink at $predate (pid $pid)\n";
	    print STDERR 
		"slink: exiting!\n";
	    exit 1;
	} else {
	    print STDERR 
		"slink: $user ($uid) left old lock $opt_lokfile from $predate\n";
	    if (! unlink($opt_lokfile))  {
		print STDERR 
		    "slink: Cannot remove dead lockfile $opt_lokfile: $!\n";
		print STDERR 
		    "slink: exiting!\n"; 
		exit 1; 
	    }
	}
    }

    open(PIDFILE, ">$opt_lokfile") 
	|| die "Can't open $opt_lokfile for writing: $!\n";
    $date = &ctime(time); chop $date; 
    print PIDFILE "$$\t$<\t$ENV{'USER'}\t$date\n";
    close PIDFILE;
    chmod 0666,$opt_lokfile; 
    $SIG{'INT'} = 'shutdown'; 
    $SIG{'QUIT'} = 'shutdown'; 
}

sub clear_lock {
    if (-f $opt_lokfile) {
	unlink($opt_lokfile) 
	    || die "slink: cannot remove lockfile $opt_lokfile: $!"; 
    }
}

######################################################################
# determine whether it's OK to run or not. 
# return 1 if OK to run, 0 if not. 
######################################################################

sub slinkhosts {
    return 1 if @opt_slinkhosts == 0; 
    local($host) = `$cmd_uname -n`; chop $host; 
    local($allowed); 
    foreach $allowed (@opt_slinkhosts) {
	return 1 if $host eq $allowed;
    }
    return 0;
}

  ##################################################################
 ####                                                            ####
####            Part 8: General-purpose utilities                 ####
 ####                                                            ####
  ##################################################################

######################################################################
# basename and prefix operations
######################################################################

# return the basename for a path, without suffix elimination

sub path_base {
    local(@name) = split('/',$_[0]); 
    return $name[$#name]; 
}

# return everything but the basename for a path

sub path_prefix {
    local(@name) = split('/',$_[0]); 
    pop(@name); 
    return join('/',@name); 
}
    
######################################################################
# 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 {
  local ($file1, $file2) = @_;
  local ($dev1, $inode1) = stat($file1);
  local ($dev2, $inode2) = stat($file2);
  return $inode1 == $inode2 && $dev1 == $dev2;
}

# shut down perl and remove lock files
sub shutdown {
    print STDERR "slink: shutting down...\n"; 
    &clear_lock if ! $opt_nolock; 
    exit 1; 
}

# print message and shut down. 
sub shutdie {
    local ($message) = @_; 
    print STDERR "slink: $message\n"; 
    &shutdown; 
}

######################################################################
# follow symbolic links to determine the true name of a file. 
# if an embedded symbolic link is absolute, then replace
#  the prefix before the link with the link value.
# if an embedded symbolic link is relative, sandwich
#  it between current prefix and suffix. 
# one exception: if a symbolic link references a reserved automount
#  tree as listed in @opt_dontresolve, do NOT resolve the link and 
#  keep it as part of the absolute pathname of the file. 
# Preconditions:
#  $base is the path to resolve, either absolute or relative. 
#  $cwd is a working directory to use as a current working directory. 
# Postconditions: 
# Either
#  the return value is the true absolute pathname of $base, 
# Or
#  $base refers to a nonexistent file and the return value is ''. 
######################################################################

sub truename {
    local($base,$cwd) = @_; 
    $base = &absolutize($base,$cwd); 
    local(@base) = split('/',$base); 
    local($i)=1; 
    while ($i<=$#base) {
	local($file) = join('/',@base[0..$i]); 
	local($suffix) = join('/',@base[$i+1..$#base]); 
	# &log_debug("checking $file (/$suffix)"); 
	if (! -e $file) {
	    return ''; 
	} elsif (-l $file) {
	    local($new) = readlink($file); 
	    # &log_debug("reading link $file -> $new");
	    local(@new) = split('/',$new); 
	    if ($new =~ /^\//) {
	    	if (!&dontresolve($new)) { 
		    # &log_debug("following link $file -> $new"); 
		    @base = (@new,@base[$i+1..$#base]); 
		    $i = 1; 
		    next; 
		} else {
		    # &log_debug("ignoring link $file -> $new"); 
		}
	    } else {
		# &log_debug("following link $file -> $new"); 
		@base = (@base[0..$i-1],@new,@base[$i+1..$#base]);
		next; 
	    }
	} elsif ($base[$i] eq '.') {
	    splice(@base,$i,1); 
	    next; 
	} elsif ($base[$i] eq '..') {
	    if ($i>=2) {
		# &log_debug("splice @base, $i-1, 2"); 
		splice(@base,$i-1,2);
		$i--; 
		next; 
	    } else {
		# &log_debug("splice @base, $i"); 
		splice(@base,$i,1); 
		next; 
	    }
	}
	$i++;
    }
    return join('/',@base); 
}

######################################################################
# determine whether a link should be resolved in determining 
# the true name of a path.  $target is the VALUE of the link.
# returns 0 if the link should be resolved normally. 
#	  1 if the link should be ignored because it points
#	    into an automount hierarchy,
######################################################################

sub dontresolve {
    local($target) = @_; 
    &log_debug("dontresolve($target)"); 
    foreach $prefix (@opt_dontresolve) {
	return 1 if $target =~ /^$prefix/; 
    }
    return 0; 
}

######################################################################
# make relative addresses absolute using current working
# directory as a reference. Call getcwd once and store its result
# in a local package variable to save time.  Second argument is 
# an artificial cwd to use instead of the real one if set
######################################################################

package absolutize; 

$absolute_cwd = ''; 

sub main'absolutize {
    local ($base,$cwd) = @_; 
    return $base if $base =~ /^\//; 
    return &absolutize'pconc($cwd,$base) if $cwd ne '';
    $absolutize'absolute_cwd = &main'getcwd 
	if $absolutize'absolute_cwd eq ''; 
    return &absolutize'pconc($absolutize'absolute_cwd,$base);
}

# concatenate a path with extra /'s around. 
sub pconc {
    local(@path) = @_; 
    local($result) = $path[0]; 
    local($seg); 
    foreach $seg (@path[1..$#path]) {
	if ($result !~ /\/$/ && $seg !~ /^\//) { $result .= '/' . $seg; } 
	else { $result .= $seg; } 
    }
    return $result; 
}