dh-ocaml 1.1.0 / usr / bin / ocaml-md5sums

#!/usr/bin/perl

use warnings;
use strict;

my $verbose = 0;

# Executable called
my $ocamlobjinfo=$ENV{OCAMLOBJINFO};
$ocamlobjinfo="ocamlobjinfo" unless defined($ocamlobjinfo);

use constant VERSION => "0.1";

sub info
{
  print STDERR (@_, "\n") if $verbose >= 1;
};

sub debug
{
  print STDERR (@_, "\n") if $verbose >= 2;
};

package OCamlMD5Sums::File;

use warnings;
use strict;

sub new
{
  my ($class,
      $dev,
      $runtime,
      $version,
      @nodefined) = @_;

  my $self = ();
  $self->{dev} = defined $dev ? $dev : "-";
  $self->{runtime} = defined $runtime ? $runtime : "-";
  $self->{version} = defined $version ? $version : "-";
  $self->{"defined"} = ();
  $self->{imported} = ();
  $self->{depends} = ();
  $self->{file} = ();
  $self->{nodefined} = ();
  $self->{nodefined}{$_} = 1 foreach @nodefined;
  $self->{checksum} = ();

  bless $self, $class;
  return $self;
};

sub set_checksum 
{
  my ($self, $checksum) = @_;
  $self->{checksum} = $checksum;
};

sub add_unit
{
  my ($self, $symbol_table, $unit_name, $md5) = @_;
  my $key = "$md5+$unit_name";
  if ($symbol_table eq "defined" && exists $self->{nodefined}{$unit_name})
  {
    main::info "Not defining unit $unit_name";
  }
  else
  {
    main::debug "Adding unit $unit_name to $symbol_table"
      unless exists $self->{$symbol_table}{$key};
    $self->{$symbol_table}{$key} = "none";
  };
};

sub get_unit
{
  my ($self, $symbol_table, $key) = @_;
  return ($2, $1) if /([^+]*)\+(.*)/;
  die "E: $key doesn't have the right format";
};

sub squeeze_imported
{
  my ($self) = @_;

  main::debug "Squeezing imported symbol";
  foreach (keys(%{$self->{"defined"}}))
  {
    if (exists($self->{imported}{$_}))
    {
      delete($self->{imported}{$_});
      main::debug("Removing internal interface $_ from imported");
    };
  };
};

sub add_object
{
  my ($self, $obj_file) = @_;

  my $interface = undef;
  my $symbol_table = undef;

  main::info "Execute $ocamlobjinfo $obj_file";
  foreach (`$ocamlobjinfo $obj_file`)
  {
    chomp $_;
    main::debug "Input line: $_";
    if (/^\s*((Unit|Module) n|N)ame: (\S+)$/)
    {
      $interface = $3;
      main::debug "Interface: $interface";
    }
    elsif (/^CRC of implementation:\s+([a-fA-F0-9]+)/)
    {
      $self->add_unit("defined", $interface, $1);
    }
    elsif (/^\s*([a-fA-F0-9]+)\s+(\S+)$/)
    {
      $symbol_table = "imported";
      $symbol_table = "defined" if defined($interface) && ($interface eq $2);
      $self->add_unit($symbol_table, $2, $1);
    };
  };
  die "E: Error running $ocamlobjinfo on $obj_file\n" if $?;

  $self->squeeze_imported();
};

sub read_dump
{
  my ($self, $file) = @_;

  my $symbol_table = undef;

  main::info "Load from dump $file";
  open(FH, $file) || die "E: Cannot open file $file";
  foreach (<FH>)
  {
    if (/(dev|runtime|version)\s+(\S+)/)
    {
      $self->{$1} = $2;
    }
    else
    {
      my ($symbol_table,$md5,$unit_name) = split /\s+/;
      $self->add_unit($symbol_table, $unit_name, $md5);
    };
  };
  close(FH) || die "E: Cannot close file $file";
  $self->squeeze_imported();
  $self->{file} = $file;
};

sub write_dump
{
  my ($self, $file) = @_;

  open(FH,">", $file) || die "E: Cannot open file $file";

  print FH "dev $self->{dev}\n";
  print FH "runtime $self->{runtime}\n";
  print FH "version $self->{version}\n";
  foreach my $symbol_table ("imported", "defined")
  {
    my $symbol_table_print = $symbol_table;
    $symbol_table_print = "defined " if $symbol_table eq "defined";
    foreach (keys(%{$self->{$symbol_table}}))
    {
      my ($unit_name, $md5) = $self->get_unit($symbol_table, $_);
      print FH "$symbol_table_print $md5 $unit_name\n";
    }
  }

  close(FH);
};

sub print
{
  my ($self) = @_;
  foreach (sort(keys(%{$self->{"defined"}})))
  {
    my ($unit_name, $md5) = $self->get_unit("defined", $_);
    print
      (join
        (" ",
         $md5,
         $unit_name,
         $self->compute_provides()));
  };
};

sub load_assign
{
  my ($self, $key, $b) = @_;
  my $a = $self->{$key};

  if ($a eq $b)
  {
    $self->{$key} = $a;
  }
  elsif ($a eq "-")
  {
    $self->{$key} = $b;
  }
  elsif ($b eq "-")
  {
    $self->{$key} = $a;
  }
  else
  {
    warn "W: $key is already defined as $a but trying to use $b instead";
  };
};

sub load
{
  my ($self, $file) = @_;
  main::debug "Load $file";
  open(FH, "<", $file) || die "E: Cannot open file $file";
  foreach (<FH>)
  {
    my ($md5, $unit_name, $dev, $runtime, $version, $ck) = split /\s+/;
    $self->load_assign("dev", $dev);
    $self->load_assign("runtime", $runtime);
    $self->load_assign("version", $version);
    $self->add_unit("defined", $unit_name, $md5);
    $self->{checksum} = $ck;
  };
  close(FH);
  $self->squeeze_imported();
  $self->{file} = $file;
};

# String representation
sub to_string
{
  my ($self) = @_;
  if ($self->{dev} eq "-" && defined($self->{file}))
  {
    return $self->{file};
  }
  else
  {
    return
      $self->{dev}.
      ($self->{runtime} ne "-" ? "/".$self->{runtime} : "").
      ($self->{version} ne "-" ? " v".$self->{version} : "");
  }
};

# Check that self depends on another package
sub add_depends
{
  my ($self, $other) = @_;

  my $already_depends = 0;

  # Compute depends
  foreach (keys(%{$self->{imported}}))
  {
    if (exists $other->{"defined"}{$_})
    {
      if ($other->{dev} ne $self->{dev})
      {
        my ($unit_name, $md5) = $self->get_unit("imported", $_);
        if (!$already_depends)
        {
          main::info($self->to_string()." depends on ".
            $other->to_string()." through ".$unit_name);
          push(@{$self->{depends}}, $other);
        };
        $already_depends = 1;
        if ($self->{imported}{$_} ne "none")
        {
          warn "W: Unit $unit_name already defined in ".
               $self->{imported}{$_}.
               " and defined again in ".
               $other->to_string().
               "\n";
        };
      };
      $self->{imported}{$_} = $other->to_string();
    };
  };

  # Check duplicate export
  if ($self->{dev} ne $other->{dev})
  {
    foreach (keys(%{$self->{"defined"}}))
    {
      my ($unit_name) = $self->get_unit("defined", $_);
      die "E: Error: unit $unit_name exported in ".
          $self->to_string().
          " but already exported by ".
          $other->to_string().
          "\n"
        if exists $other->{"defined"}{$_};
    };
  };
};

sub print_depends
{
  my ($self) = @_;

  print $_->compute_provides() foreach (@{$self->{depends}});

  foreach (keys(%{$self->{imported}}))
  {
    if ($self->{imported}{$_} eq "none")
    {
      my ($unit_name, $md5) = $self->get_unit("imported", $_);
      warn "W: ".$self->to_string().
           " doesn't resolve dependency on unit ".
           $unit_name.
           "\n"
           # MD5 = 0 means that we encounter an object which
           # .cmxa has been used instead of its .cmx
           unless $md5 eq "00000000000000000000000000000000";
    };
  };
};

sub check_exported
{
  my ($self, $other) = @_;
};

use Digest::MD5 qw/md5_hex/;

sub compute_provides 
{
  my ($self) = @_;

  my $ck = $self->{checksum};
  if (!$ck)
  {
    my $hex = md5_hex(join("",sort keys(%{$self->{"defined"}})));
    my $sig = hex(substr($hex, 0, 6));
    my $fact;
    my @fact_print;
    for (my $i = 0; $i < 5; $i++)
    {
      $fact = $sig % 36;
      $sig = $sig / 36;
      push(@fact_print, (chr ($fact + ($fact < 10 ? (ord '0') : ((ord 'a') - 10)))));
    };

    $ck = join "", @fact_print;
  };

  return "$self->{dev} $self->{runtime} $self->{version} $ck\n";
};

sub dump_provides
{
  my ($self, $file) = @_;
  my $ck = $self->compute_provides();
  open(FH, ">", $file) || die "E: Cannot open file $file";
  print FH ($self->compute_provides());
  close(FH);
};

1;

package main;

use Getopt::Long;
use Pod::Usage;
use File::Glob;;

my $man = 0;
my $help = 0;
my $action = undef;
my @objects;
my $package_dev;
my $package_runtime;
my $package_version;
my $dump_info_fn;
my $load_info_fn;
my $print_version;
my $dump_provides;
my $checksum;
my @md5sums_dirs=("/var/lib/ocaml/md5sums");
my @nodefined = ();

sub process_not_option
{
  if (defined($action))
  {
    push @objects, @_;
  }
  else
  {
    $action = $_[0];
  };
}

sub get_objects
{
  my ($already_loaded) = @_;
  return <STDIN> unless @objects > 0 || $already_loaded;
  return @objects;
}

GetOptions(
  "package=s"       => \$package_dev,
  "runtime=s"       => \$package_runtime,
  "version=s"       => \$package_version,
  "dump-info=s"     => \$dump_info_fn,
  "load-info=s"     => \$load_info_fn,
  "dump-provides=s" => \$dump_provides,
  "md5sums-dir=s"   => \@md5sums_dirs,
  "nodefined=s"     => \@nodefined,
  "checksum=s"      => \$checksum,
  "my-version"      => \$print_version,
  "v+"              => \$verbose,
  "<>"              => \&process_not_option,
  "help|?"          => \$help,
  "man"             => \$man) or pod2usage(2);
pod2usage(1) if $help;
pod2usage(-exitstatus => 0, -verbose => 2) if $man;

if ($print_version)
{
  print(VERSION,"\n");
  exit 0;
};

die "E: No action\n" unless defined($action);

if ($action eq "compute" || $action eq "dep")
{
  my $md5sums =
    OCamlMD5Sums::File->new
      ($package_dev,
       $package_runtime,
       $package_version,
       @nodefined);
  $md5sums->set_checksum($checksum) if defined($checksum);
  $md5sums->read_dump($load_info_fn) if defined($load_info_fn);
  foreach (get_objects(defined($load_info_fn)))
  {
    info("Processing $_");
    $md5sums->add_object($_);
  };

  die "E: No dev. package defined" unless defined($md5sums->{dev});

  $md5sums->write_dump($dump_info_fn) if defined($dump_info_fn);

  if ($action eq "compute")
  {
    $md5sums->print();
  }
  else # dep
  {
    foreach my $md5sums_dir (@md5sums_dirs)
    {
      my @files = <$md5sums_dir/*.md5sums>;
      foreach (@files)
      {
        my $other_md5sums = OCamlMD5Sums::File->new();
        $other_md5sums->load($_);
        $md5sums->add_depends($other_md5sums);
      };
    };
    $md5sums->print_depends ();
  }

  $md5sums->dump_provides($dump_provides) if (defined($dump_provides));
}
elsif ($action eq "update")
{
  # do nothing, on purpose
}
else
{
  die "E: Unknown action $action\n";
};

__END__

=head1 NAME

ocaml-md5sum - Use and maintain ocaml md5sums registry files

=head1 SYNOPSIS

ocaml-md5sum (compute|dep) [option ...] file ...
ocaml-md5sum update [option ...]

B<compute> dump the content of the the md5sums files to output. B<dep> compute
dependencies of the package, using md5sums files that can be found.

=head1 OPTIONS

=over 8

=item B<--package> pkg

Set package name for development dependency.

=item B<--runtime> pkg

Set package name for runtime dependency.

=item B<--version> ver

Set package version for dependencies.

=item B<--dump-info> fn

Dump ocamlobjinfo to file.

=item B<--load-info> fn

Restore ocamlobjinfo from file.

=item B<-v>

Increase verbosity.

=item B<--my-version>

Print ocaml-md5sum version and exit.

=item B<--nodefined> unit

Avoid export of OCaml unit into md5sums file.

=item B<--dump-provides> fn

Write provides for the package into given file.

=item B<--md5sums-dir> dir

Add directory to the list of directory looked for md5sums files.

=item B<--checksum> str

Checksum to use.

=item B<-help>

Print a brief help message and exits.

=item B<-man>

Prints the manual page and exits.

=back

=cut