#! /local/bin/perl

######################################################################
# $Header: /loc/adm/slink-1.0/src/slink-5.0/RCS/slinkls,v 5.0 1996/05/13 17:15:49 couch Exp couch $
# Slinkls: make a listing of a directory hierarchy according to slink
#  Revision 5.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
#
#  Slink-1.0 Copyright (C) 1995 by Alva L. Couch and Greg Owen
#  Slink-2.0 Copyright (C) 1995 by Alva L. Couch
#  Slink-3.0 Copyright (C) 1996 by Alva L. Couch
#  Slink-4.0 Copyright (C) 1996 by Alva L. Couch
#  Slink-5.0 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.
######################################################################
#  Slinkls prints a map of high-level linkages in a given directory, 
#  expressing them in the highest level form, i.e., using the 
#  highest nodes it can in the tree it's given. 
#  Options: 
#   -links: make links show up even if subsumed by slinks (dir-dir links)
#   -slinks: make lower level slinks show up even if subsumed by higher
#      level ones. 
######################################################################

require "newgetopt.pl"; 
use Slink::TrueName(qw(truename truequiv truelink absolute)); 

use strict; 

$main::opt_links = 0; 
$main::opt_slinks = 0; 
if (!&NGetOpt('-','links','slinks')) {
   print STDERR "truename usage:\n"; 
   print STDERR "truename [-links] [-slinks] file1 file2 ...\n"; 
   print STDERR "  -links: report links subsumed by slinks\n"; 
   print STDERR "  -slinks: report slinks subsumed by other slinks\n"; 
   exit(1); 
} 

# $cwd is instantiated by the first call that needs it and 
# passed to all other calls. 
my $node;
my $cwd; 
if ($#ARGV>=0) {
    foreach $node (@ARGV) {
	$node = &Slink::TrueName::absolute($node,$cwd); 
	print "hierarchy for $node:\n"; 
	Ls::ls($node,$main::opt_links,$main::opt_slinks); 
    }
} else {	# saying nothing => '.'
    $node = &Slink::TrueName::absolute('.',$cwd); 
    print "hierarchy for $node:\n"; 
    Ls::ls($node,$main::opt_links,$main::opt_slinks); 
}
exit(0); 

######################################################################
# Compute and print a map of confluences in a directory hierarchy
# This package does an ls of a filesystem tree and computes the slinks
# in effect in that tree.  These are not the logical slinks
# constructed by linking, but the highest-level physical slinks one
# can derive from existing structure.  Barring protection failures,
# these physical slinks cannot be lower-level than logical slinks but
# can be higher-level if it just happens that a lower-level slink is
# the only thing defining the contents of a parent directory.  E.g.
# if you slink /local/random/foo => /loc/random/foo, and there's
# nothing else in /local/random or /loc/random, then this program will
# report that /local/random => /loc/random even though you didn't
# construct things that way.
#
# two directories are confluent if everything in the second is pointed
# to by the first, whether or not links are actually resolved from the
# second directory.  This means that truename calls cannot be counted
# upon to solve the dereferencing problem, because if links in the
# target point nowhere, they can still be part of a confluence.
# For this reason we use the routine &truequiv to determine
# whether confluence exists between two (possibly dangling) links. 
######################################################################

package Ls; 

use Cwd; 

# tree returns a complex data structure that fully describes links
# and slinks in the tree upon which it's invoked. 
# return value is a reference to an assoc list of the form: 
# $map = {$path => [$type, {$linkname => $linktype, ...}]} 
# where we wish to record BOTH original status of a link and 
# status in slinking...
# "/foo"  => [0]	  means foo doesn't exist. 
# "/foo"  => [1]	  means foo is a file of some sort. 
# "/foo"  => [2]	  means foo is device-special. 
# "/foo"  => [3,{..}]	  means foo is a link, 
#			  with associative array of links(1 only)
# "/foo"  => [4,{..}]	  means foo is a directory, 
#			  with associative array of slinks
# "/foo" => [3, {"/bar" => 0}] means foo is an absorbed symlink to bar
#			  (part of some other slink). 
# "/foo" => [4, {"/bar" => 0}] means foo is an absorbed slink to bar
#			  (part of some other slink). 
# "/foo" => [3, {"/bar" => 1}] means foo is a symlink to bar
#			  (lowest-level slink)
# "/foo" => [4, {"/bar" => 1}] means foo is a slink to bar
#			  (highest-level slink)
sub tree {
    my ($node) = @_; 
    if (-l $node) { 
        # Checking for confluence requires the next link after
	# the current one, returned by special function &truelink. 
	# symlinks are type 3. 
	return { $node => [3, { &Slink::TrueName::truelink($node) => 1 }] } ; 
    } elsif (! -e $node) { 
	return { $node => [0] } ; 
    } elsif (-f $node) {
	return { $node => [1] } ; 
    } elsif (! -d $node) {
	return { $node => [2] } ; 
    } else { # -d $node
	# directories start with no slinks defined. 
	my($map) = { $node => [4,{}] }; 
	if (opendir(DIR,$node)) {
	    my(@subs) = readdir DIR; closedir(DIR); 
	    my($sub);
	    foreach $sub (@subs) {
		next if $sub eq '.' || $sub eq '..'; 
		my($new) = &tree("$node/$sub"); 
		&addassoc($map,$new); 
	    }

	    # now reduce confluent links by looking backward from each target
	    # each link that's confluent has several others that also point
	    # to the same subdirectory. Reduce all at once if one is present. 
	    foreach $sub (@subs) {
		next if $sub eq '.' || $sub eq '..'; 
		my($path) = "$node/$sub"; 
		my($type) = $map->{$path}->[0]; 
		my($targets) = $map->{$path}->[1]; 
		# skip things that can't link to anything
		next if $type < 3 || ref($targets) ne 'HASH'; 
		my($target); 
		foreach $target (keys %$targets) {
		    # don't run on unmapped structures 
		    next if ! $targets->{$target}; 
		    my($pref) = &prefix($target); 
		    if ($pref ne $node) {
			if (opendir(DIR,$pref)) {
			    my(@sons) = readdir DIR; closedir(DIR); 
			    my($matched) = 1; 
			    my $son; 
			    foreach $son (@sons) {
				next if $son eq '.' || $son eq '..'; 
				my($pith) = "$pref/$son"; 
				my($poth) = "$node/$son"; 
				if (! (&Slink::TrueName::truequiv("$pref/$son","$node/$son"))) {
				    $matched = 0; last; 
				}
			    }
			    # check if got here without last => got a confluence
			    # in this case, delete all references to $node/$son
			    # and replace with a slink $node => $pref. 
			    if ($matched) {
				foreach $son (@sons) {
				    next if $son eq '.' || $son eq '..'; 
				    my($poth) = "$node/$son"; 
				    my($pith) = "$pref/$son"; 
				    my($type) = $map->{$poth}[0]; 
				    my($targets) = $map->{$poth}[1]; 
				    next if $type<3 || ref($targets) ne 'HASH'; 
				    # consumed symlinks or slinks are status 0
				    # but be careful to refer to them
				    # by their local names only!
				    my($target); 
				    foreach $target (keys %$targets) {
					# we are only guaranteed that
					# ONE of the targets matches!
					if (&Slink::TrueName::truequiv($pith, $target)) {
					    $targets->{$target} = 0; 
					}
				    }
				}
				# there's a slink from $node -> $pref
				$map->{$node}[1]->{$pref} = 1; 
			    }

			} else {
			    print STDERR "Ls::tree: can't open directory $pref - ignoring\n"; 
			} 
		    }
		}
	    }
	} else {
	    print STDERR "Ls::tree: can't open directory $node - ignoring\n"; 
	}
	return $map; 
    } 
}

# This routine prints the filesystem tree constructed by tree
# and takes options for what to emphasize
# Usage: &print $map,$links,$slinks; 
# Preconditions:  
# $map is a reference returned by &tree
# $links == 0 means don't print links that are part of slinks
# $links == 1 means to print links that are part of slinks
# $slinks == 0 means don't print slinks that are part of other slinks
# $slinks == 1 means to print slinks that are part of other slinks
# Postconditions: the tree is printed on the appropriate device
# and the return value is $map. 
sub print {
    my($fd) = \*STDOUT; 
    $fd = shift @_ if defined fileno($_[0]); 
    my($map,$links,$slinks)= @_; 
    my($source); 
    my(@sources) = sort keys(%$map); 
    foreach $source (@sources) {
	my($type) = $map->{$source}[0]; 
	my($targets) = $map->{$source}[1]; 
	if ($type == 0) {
	    print $fd "$source (nonexistent)\n"; 
	} elsif ($type == 1) {
	    print $fd "$source (file)\n"; 
        } elsif ($type == 2) {
	    print $fd "$source (special)\n"; 
        } elsif ($type == 3) {
	    my(@targets) = sort keys %$targets; 
	    my($active) = 0; 
	    my($key); 
	    if (! $links) {
		foreach $key (@targets) {
		    $active = 1 if $targets->{$key}; 
		}
	    }
	    if ($active || $links) {
		print $fd "$source (link)\n"; 
		if ($#targets>=0) {
		    my($target); 
		    foreach $target (@targets) {
			if ($targets->{$target}) {
			    print $fd "  -> $target\n"; 
			} elsif ($links) {
			    print $fd "  (->$target)\n"; 
			}
		    }
		}
	    }
	} elsif ($type == 4) {
	    my(@targets) = sort keys %$targets; 
	    my($active) = 0; 
	    my($key); 
	    if (!$slinks) {
		foreach $key (@targets) {
		    $active = 1 if $targets->{$key}; 
		}
	    }
	    if ($active || $slinks) {
		print $fd "$source (directory)\n"; 
		if ($#targets>=0) {
		    my($target); 
		    foreach $target (@targets) {
			if ($targets->{$target}) {
			    print $fd "  => $target\n"; 
			} elsif ($slinks) {
			    print $fd "  (=>$target)\n"; 
			}
		    }
		}
	    }
	} else {
	    print $fd "$source (UNKNOWN)\n"; 
	}
    }
    return $map; 
}

sub ls {
    my($thing,$links,$slinks) = @_; 
    my($map) = &tree($thing); 
    &print(\*STDOUT,$map,$links,$slinks); 
}

# combine one associative array into another
# $src and $dst are references to associative arrays. 
# at return, elements of $src have been copied into $dst. 
# the destination array reference is returned for convenience. 
sub addassoc {
    my($dst,$src) = @_; 
    my ($key,$value); 
    while (($key,$value) = each %$src) { 
	$dst->{$key} = $value; 
    }
    return $dst; 
}

# return everything but the basename for a path
# prefix's single argument is a string containing a pathname.
# It returns a new string without the basename.
sub prefix {
    my(@name) = split('/',$_[0]); 
    pop(@name); 
    return join('/',@name); 
}