1 files changed, 166 insertions, 0 deletions
diff --git a/mcon/pl/tsort.pl b/mcon/pl/tsort.pl
new file mode 100644
index 0000000..4d56fae
--- /dev/null
+++ b/mcon/pl/tsort.pl
@@ -0,0 +1,166 @@
+;# $Id$
+;#
+;#  Copyright (c) 1991-1997, 2004-2006, Raphael Manfredi
+;#  
+;#  You may redistribute only under the terms of the Artistic Licence,
+;#  as specified in the README file that comes with the distribution.
+;#  You may reuse parts of this distribution only within the terms of
+;#  that same Artistic Licence; a copy of which may be found at the root
+;#  of the source tree for dist 4.0.
+;#
+;# $Log: tsort.pl,v $
+;# Revision 3.0  1993/08/18  12:10:28  ram
+;# Baseline for dist 3.0 netwide release.
+;#
+;# 
+;# The topological sort is performed using the following algorithm:
+;#
+;# We have a list of successors for each item; makefile dependencies of
+;# the form 'a b: c d' means successors(a) = successors(b) = { c, d }.
+;# From that input, we derive a number of precursors for each item.
+;# In our simple example above, c and d both have two precursors and
+;# a and b have none. Items with no precursors are called outsiders
+;# and are left in a pool. The sort is then initiated and will continue
+;# until all the items have been sorted or a cycle is found...
+;#
+;# Outsiders are ready to be sorted; since the topological sort is a partial
+;# order, an external criterion is needed to choose one item among the ones
+;# in the pool. That item is assigned a number, and the number of precursors
+;# for the remaining items is updated (by following the successors of the
+;# sorted item and decrementing the value for each successor). Among those,
+;# if any item reaches a precursor count of zero, it becomes an outsider.
+;#
+;# The algorithm ends when the outsider pool is empty. If it becomes empty and
+;# some items remain unsorted, then there is one or more cycles among them.
+;# One way to outline that cycle first extract all those items whose precursor
+;# count is minimal then visit their dependency graph to find the cycle,
+;# extract only those items belonging to the cycle into the outsiders set and
+;# resume the main processing stream.
+;#
+#
+# Topological sort of Makefile dependencies with cycle enhancing.
+#
+
+package tsort;
+
+# Perform the topological sort of the items and outline cycles.
+sub main'tsort {
+	local(*Succ, *Prec) = @_;	# Tables of succesors and predecessors
+	local(@Out);				# The outsider set
+	local(@keys);				# Current active precursors
+	local($item);				# Item to sort
+
+	for (@keys = keys %Prec; @keys || @Out; @keys = keys %Prec) {
+		&resync;			# Resynchronize outsiders
+		if (@Out == 0) {	# Cycle detected
+			&extract_cycle(*Prec, *Succ);
+			next;
+		}
+		$item = shift(@Out);	# Sort current item (don't care which one)
+		&sort($item);		# Update internal structures
+	}
+}
+
+# Resynchronize the outsiders stack (those items that have no more precursors).
+# If the outsiders stack becomes empty, then there is a cycle.
+sub resync {
+	foreach $target (keys %Prec) {
+		if ($Prec{$target} == 0) {
+			delete $Prec{$target};		# We're done with this item
+			push(@Out, $target);		# Ready to be sorted
+		}
+	}
+}
+
+# Sort item
+sub sort {
+	local($item) = @_;
+	print "(ok) $item\n" if $main'opt_d && !$Cycle;
+	print "(fx) $item\n" if $main'opt_d && $Cycle;
+	foreach $succ (split(' ', $Succ{$item})) {
+		# The test for definedness is necessary, since when a cycle is found,
+		# one item is forced out of %Prec. If we had the guarantee of no
+		# cycle, the the test would not be necessary and no decrementation
+		# could go past 0.
+		$Prec{$succ}-- if defined $Prec{$succ};
+	}
+}
+
+# Extract cycle... We look through the %Prec array and find all those items
+# with the same lowest value. Those are a cycle, so we dump them, and make
+# them new outsiders by resetting their count to 0.
+sub extract_cycle {
+	local(*Prec, *Succ) = @_;
+	local($item) = (&sort_by_value(*Prec))[0];
+	local($min) = $Prec{$item};			# Minimum value
+	local($key, $value);
+	local(%candidate);	# Superset of the cycle we found
+	warn "    Cycle found for:\n";
+	$Cycle++;
+	while (($key, $value) = each %Prec) {
+		$candidate{$key}++ if $value == $min;
+	}
+	local(%state);		# State of visited nodes (1 = cycle, -1 = dead)
+	local($CYCLE) = 1;	# Possible member of a cycle
+	local($DEAD) = -1;	# Dead end, no cycling possible
+	foreach $key (keys %candidate) {
+		last if $CYCLE == &visit($key, $Succ{$key});
+	}
+	while (($key, $value) = each %candidate) {
+		next unless $state{$key} == $CYCLE;
+		$Prec{$key} = 0;			# Members of cycle are new outsiders
+		warn "\t(#$Cycle) $key\n";
+	}
+	local(%involved);	 # Items involved in the cycle...
+	while (($key, $value) = each %state) {
+		$involved{$key}++ if $state{$key} == $CYCLE;
+	}
+	&outline_cycle(*Succ, *involved);
+}
+
+sub outline_cycle {
+	local(*Succ, *member) = @_;
+	local($key, $value);
+	local($depends);
+	local($unit);
+	warn "    Cycle involves:\n";
+	while (($key, $value) = each %Succ) {
+		next unless $member{$key};
+		$depends = '';
+		foreach $item (split(' ', $value)) {
+			$depends .= "$item " if $member{$item};
+		}
+		$unit = $main'shmaster{"\$$key"};
+		$unit =~ s/\s+$//;
+		$unit = '?' if $unit eq '';
+		warn "\t($unit) $key: $depends\n";
+	}
+}
+
+# Visit a tree node, following all its successors, until we find a cycle.
+# Return $CYCLE if the exploration of the node leaded to a cycle, $DEAD
+# otherwise.
+sub visit {
+	local($node, $children) = @_;	# A node and its children
+	# If we have already visited the node, return the status value attached
+	# to it.
+	return $state{$node} if $state{$node};
+	$state{$node} = $CYCLE;			# Assume member of cycle
+	local($all_dead) = 1;			# Set to 0 if at least one cycle found
+	foreach $child (split(' ', $children)) {
+		$all_dead = 0 if $CYCLE == &visit($child, $Succ{$child});
+	}
+	$state{$node} = $DEAD if $all_dead;
+	$state{$node};
+}
+
+# Sort associative array by value
+sub sort_by_value {
+	local(*x) = @_;
+	sub _by_value { $x{$a} <=> $x{$b}; }
+	sort _by_value keys %x;
+}
+
+package main;
+
+1;