#!/usr/bin/env perl
#
# This takes in a list of *.cmo files and orders them topologically.
# This errors out if there is a cycle.
# This uses "ocamlobjinfo" and "tsort", both of which must be in the PATH.
# This prints out the *.cmo files in order so that a link will succeed.

sub usage
{
  print STDERR "Usage: ocamlorder <*.cmo>\n";
  exit 1;
}

sub main
{
  usage() unless @ARGV;
  
  # Read in the dep information
  my %deps;
  my %map;
  my @avail = map { modname($_) } @ARGV;
  
  foreach my $x ( @ARGV ) {
    my $name = modname($x);
    $map{$name} = $x;
    $deps{$name} = find_deps($x, \@avail);
  }

  # Do a topo-sort

  my $order = topo_sort(\%deps);
  
  # Map back to input file names

  my @sorted = map { $map{$_} } @$order;
  
  # Write out the results

  print "@sorted\n";

  exit(0);
}

# foo/bar.cmo => bar
sub modname
{
  my( $fname ) = @_;
  $fname =~ s|\..*?$||;
  $fname =~ s|.*/||;
  return ucfirst($fname);
}

# Use ocamlobjinfo to list deps. Only return a list of
# those deps that exist in the given list of names.
sub find_deps
{
  my( $file, $avail ) = @_;
  
  my @cmd = ('ocamlobjinfo', $file);

  my $imp = 0;
  my @found;
  my $self = modname($file);
  
  open( INFO, "-|", @cmd ) or die "Can't run 'ocamlobjinfo': $!\n";

  while ( <INFO> ) {
    # Interfaces imported:
    #        71f888453b0f26895819460a72f07493        Pervasives
    #        ...
    if ( /Interfaces\s+imported/ ) {
      $imp = 1;
    }
    
    if ( $imp ) {
      if ( /^\s*[0-9a-f]{32}\s+(\S+)\s*$/ ) {
        my $name = $1;
        if ( grep { $_ eq $name and $_ ne $self } @$avail ) {
          push @found, $name;
        }
      }
    }
  }
  
  close( INFO ) or die "Running 'ocamlobjinfo' failed: $! $?\n";
  
  return \@found;
}

# Take a hash that maps strings to dependencies, return
# a topologically sorted list
my $tf;
END { unlink($tf) if $tf; }

sub topo_sort
{
  my( $deps ) = @_;
  
  $tf = "/tmp/ocamlorder.$$" unless $tf;
  
  open( TMP, ">$tf" ) or die "Can't write '$tf': $!\n";
  
  foreach my $d ( keys %$deps ) {
    my @v = @{$deps->{$d}};
    foreach my $v ( @v ) {
      print TMP "$v $d\n";
    }
  }
  
  close( TMP ) or die "Can't write '$tf': $!\n";
  
  # Use tsort

  my @sorted;
  my @cmd = ('tsort', $tf);
  
  open( TS, "-|", @cmd ) or die "Can't run 'tsort': $!\n";

  while ( <TS> ) {
    chomp;
    push @sorted, $_;
  }
  
  close( TS ) or die "Running 'tsort' failed: $! $?\n";
  
  return \@sorted;
}

main();
