# compareDeployed.pl
# Peter Webb, Feb. 2014
# Copyright (C) The MathWorks 2014
#
# Compare two deployed components (applications or shared libraries) created
# by the MATLAB Compiler. Exit with status 0 if they are equal (thanks, UNIX,
# and strcmp for your counter-intuitive, but now conventional, behavior) and
# non-zero if they are not equal.
#
# If the -explain switch is specified, list all the reasons (not just the
# first reason) that the components are not equal.
#
# Usage:
#    perl compareDeployed.pl [-explain] [-keep] [-verbose] deployed-1 deployed-2
# 

use strict;
use warnings;
use Archive::Zip qw( :ERROR_CODES :CONSTANTS );
use File::Temp qw( tempfile tempdir );
use File::Basename;
use Env;
use XML::LibXML;

sub getNodeAttribute
{
    my $xml = shift;       # XML document
    my $xpth = shift;      # XPath to an element in the document
    my $attr = shift;      # Name of an attribute of the element

    my $keyNodeList = $xml->findnodes($xpth);
    die "Multiple nodes with path $xpth" if ($keyNodeList->size() > 1);
    my $keyNode = $keyNodeList->get_node(1);

    # TODO: Can we recover file name from XML document? Error message would
    # be better with file name.
    die "Could not locate XML element $xpth." if (! $keyNode);

    # Node may have value "0", which tests false in Perl (thanks, Larry, for
    # that ambiguity). So we must test for attribute existence first (since
    # we can't rely on the return value to distinguish between "0", 0 and 
    # undef.
    die "XML element $xpth has no attribute named $attr"
      if (! $keyNode->hasAttribute("$attr") );

    # Attribute putatively exists. Fetch and return value.
    my $attrNode = $keyNode->getAttribute("$attr");
    $attrNode;
}

sub compareMCR
{
    my $manifests = shift;
    my $idManifests = shift;
    my $deployedOne = shift;
    my $deployedTwo = shift;
    my $verbose = shift;

    # compareMCR doesn't use the identity manifest.
    die "Empty manifest object. Unable to compare MCR version numbers.\n"
      if (! $manifests);

    my $result = 1;
    my $reason = "";

    # Extract the MCR version numbers from the manifests.
    my $manifestPath = "/manifest";
    my $mcrMajor = "mcr-major-version";
    my $mcrMinor = "mcr-minor-version";

    my $mcrOne =
      getNodeAttribute($manifests->[0], $manifestPath, $mcrMajor) .  "." .
      getNodeAttribute($manifests->[0], $manifestPath, $mcrMinor);

    my $mcrTwo =
      getNodeAttribute($manifests->[1], $manifestPath, $mcrMajor) .  "." .
      getNodeAttribute($manifests->[1], $manifestPath, $mcrMinor);

    # Determine result, format reason string.
    $result = ($mcrOne eq $mcrTwo);
    my $eql = "are";
    if (!$result) { $eql = $eql . " not"; }
    $reason = "MCR version numbers ($mcrOne, $mcrTwo) $eql equal";

    [ 'MCR', $result, $reason ];
}

sub compareTargetType
{
    my $manifests = shift;
    my $idManifests = shift;
    my $deployedOne = shift;
    my $deployedTwo = shift;
    my $verbose = shift;

    # compareTargetType doesn't use the identity manifest.
    die "Empty manifest object. Unable to compare target type.\n"
      if (! $manifests);

    my $result = 1;
    my $reason = "";

    # Extract the target type from the manifests.
    my $manifestPath = "/manifest";
    my $targetType = "target_type";
    
    my $targetTypeOne =
      getNodeAttribute($manifests->[0], $manifestPath, $targetType);

    my $targetTypeTwo =
      getNodeAttribute($manifests->[1], $manifestPath, $targetType);

    # Determine result, format reason string.
    $result = ($targetTypeOne eq $targetTypeTwo);
    my $eql = "are";
    if (!$result) { $eql = $eql . " not"; }
    $reason = "Target Type ($targetTypeOne, $targetTypeTwo) $eql equal";

    [ 'Target Type', $result, $reason ];
}

sub getNodeListAttributeHash
{
    # Make a hash table from the XML attributes of a node list. Find all the
    # nodes matching $xpth, then create:
    #
    #  result { key_attribute } = value_attribute
    # 

    my $xml = shift;
    my $xpth = shift;
    my $keyAttr = shift;
    my $valAttr = shift;
    my $retval = {};

    foreach my $section ( $xml->findnodes($xpth) )
    {
        my $k = $section->getAttribute($keyAttr);
        die "Node matching $xpth has no key attribute $keyAttr"
          if (! $k);
        my $v = $section->getAttribute($valAttr);
        die "Node matching $xpth has no value attribute $valAttr"
          if (! $v);
        
        $retval->{$k} = $v;
    }
    $retval;
}

sub subtract
{
    # Array subtraction: A3 = A1 - A2.

    # Lots of lookup, so hashing the array contents for performance.
    my $a1 = shift;
    my $a2 = shift;
    my %h1 = map { $_ => 1 } @$a1;
    my %h2 = map { $_ => 1 } @$a2;

    my $a3 = [];
    
    # Add element of A1 to A3 if the element doesn't exist in A2.
    map { push(@$a3, $_) if (! exists $h2{$_});  } keys %h1;
    $a3;
}

sub compareFileList
{
    my $manifests = shift;
    my $idManifests = shift;
    my $deployedOne = shift;
    my $deployedTwo = shift;
    my $verbose = shift;

    my $result = 1;
    my $reason = "Deployed files are identical";

    # Extract the <Parts> list into a hash: parts{ name } => signature.
    my $partsOne = getNodeListAttributeHash($idManifests->[0], "Parts/Part",
                                            "name", "signature");
    die "Could not read file list from $deployedOne" if (!$partsOne);
    
    my $partsTwo = getNodeListAttributeHash($idManifests->[1], "Parts/Part",
                                            "name", "signature");
    die "Could not read file list from $deployedTwo" if (!$partsTwo);

    # Compare the hashes to determine if the file lists are equal.

    my @filesOne = keys %$partsOne;
    my @filesTwo = keys %$partsTwo;

    # First test: same number of files.
    
    my $fileCountOne = scalar @filesOne;
    my $fileCountTwo = scalar @filesTwo;
    if ($fileCountOne != $fileCountTwo)
    {
        $result = 0;
        $reason = "Deployed file lists are not the same size. $deployedOne: "
          . " $fileCountOne. $deployedTwo: $fileCountTwo";
        if ($verbose)
        {
            $reason = $reason . ".\n" . "Files in $deployedOne:\n  " .
              join("\n  ", @filesOne) . "\nFiles in $deployedTwo:\n  " .
              join("\n  ", @filesTwo);
        }
    }

    # Second test: each application contains exactly the same set of files.
    if ($result)
    {
        my $OneMinusTwo = subtract(\@filesOne, \@filesTwo);
        my $TwoMinusOne = subtract(\@filesTwo, \@filesOne);
        
        if (scalar(@$OneMinusTwo) > 0)
        {
            $result = 0;
            my $plural = "";
            $plural = "s" if scalar(@$OneMinusTwo) > 1;
            $reason = "$deployedOne contains " . scalar(@$OneMinusTwo) .
              " file" . $plural . " not in $deployedTwo";
            if ($verbose)
            {
                $reason = $reason . ":\n" . join("  \n", @$OneMinusTwo);
            }
        }
        elsif (scalar(@$TwoMinusOne) > 0)
        {
            $result = 0;
            my $plural = "";
            $plural = "s" if scalar(@$TwoMinusOne) > 1;
            $reason = "$deployedTwo contains " . scalar(@$TwoMinusOne) .
              " file" . $plural . " not in $deployedOne";
            if ($verbose)
            {
                $reason = $reason . ":\n" . join("  \n", @$TwoMinusOne);
            }
        }
    }

    # Third test: file contents are identical.
    my @diffList = ();
    if ($result)
    {
        foreach my $file (@filesOne)
        {
            my $sigOne = $partsOne->{$file};
            my $sigTwo = $partsTwo->{$file};
            
            if (! ($sigOne eq $sigTwo))
            {
                $result = 0;
                push @diffList, $file;
            }
        }
        if (! $result)
        {
            $reason = "Contents of deployed files differ";
            if ($verbose)
            {
                $reason = $reason . ". Non-identical files:\n" .
                  join("  \n", @diffList);
            }
        }
    }

    [ 'FileList', $result, $reason ];
}

# Open and parse an XML file into a document object.
sub getXML
{
    my $xmlFile = shift;

    die "Could not locate XML file $xmlFile"
      if (!-f $xmlFile);

    my $parser = XML::LibXML->new();
    my $doc = $parser->parse_file($xmlFile);

    die "Could not parse XML file $xmlFile" if (! $doc);

    $doc
}

sub usage
{
    print "Usage: \n";
    print "$0 [-explain] deployed-1 deployed-2";
}

sub openZipArchive
{
    my $zipArchive = shift;
    my $zip = Archive::Zip->new();
    my $zipStatus = $zip->read( $zipArchive );
    unless ( $zipStatus  == AZ_OK ) { 
        my $zipFailure = zipFailureReason($zipStatus);
        my $causeOfDeath = "Could not read ZIP archive $zipArchive: " .
          $zipFailure . ".";
        die $causeOfDeath;
    }
    $zip;
}

sub extractZipArchive
{
    my $zipArchive = shift;
    my $extractDir = shift;

    # How big is the binary wrapper? EOCD occurs at the very end of the ZIP
    # file. Usually (from ZIP's point of view) EOCD is zero. But since the
    # MATLAB Compiler has prefixed the ZIP file with a platform-specific 
    # binary, the EOCD is offset by exactly the size of the binary.
    my $zip = openZipArchive($zipArchive);
    my $eocd = $zip->eocdOffset();

    # Open the compiled component to extract the zip archive.
    # Advance the file pointer to the very beginning of the zip archive. 
    open (my $ctfFH, "<", $zipArchive) ||
      die "Cannot open ZIP archive $zipArchive: $!";
    binmode $ctfFH;
    seek($ctfFH, $eocd, 0);

    # Open a new (temporary) file to store the ZIP archive content.
    my $zipBase = basename($zipArchive);
    my $zipPart = "$extractDir/$zipBase.zip";
    open(my $zipFH, ">", $zipPart) ||
      die "Cannot open ZIP archive temporary file $zipPart: $!";
    binmode $zipFH;

    # Copy the ZIP content to the new file, $bufMax bytes at a time.
    my $bufMax = 4096;
    my $bytesRead = 0;
    do 
      {
          $bytesRead = read($ctfFH, my $bytes, $bufMax);
          print $zipFH $bytes;
      } while ($bytesRead == $bufMax);
    
    close $zipFH;
    close $ctfFH;

    # Return the name of the extracted temporary archive.
    $zipPart;
}

sub extractFiles
{
    my $zipArchive = shift;
    my $extractDir = shift;
    my $fileNames = shift;
    my $causeOfDeath = "";

    # Extract 
    my $zip = Archive::Zip->new();
    my $zipStatus = $zip->read( $zipArchive );
    unless ( $zipStatus  == AZ_OK ) { 
        my $zipFailure = zipFailureReason($zipStatus);
        $causeOfDeath = "Could not read ZIP archive $zipArchive: " .
          $zipFailure . ".";
        return $causeOfDeath;
    }

    # Extract the named files -- note, the specified file names much exactly
    # match the names in the archive, which means they must be relative to 
    # the root of the archive.
    map {
        my $extractPath = "$extractDir/$_";
        my $member = $zip->memberNamed($_);
        if (!$member)
        {
            $causeOfDeath = "$zipArchive does not contain $extractPath";
            return $causeOfDeath;
        }

        my $extract = $zip->extractMember($_, $extractPath);
        if ($extract != AZ_OK)
        {
            $causeOfDeath = "Failed to extract $extractPath from $zipArchive";
            return $causeOfDeath;
        }
    } @$fileNames;

    $causeOfDeath;
}

sub zipFailureReason
{
    my $errCode = shift;
    my $reason = "Error or errors unknown";
    if ($errCode == AZ_FORMAT_ERROR)
      { $reason = "Badly formatted ZIP archive"; }
    elsif ($errCode == AZ_IO_ERROR)
      { $reason = "Non-specific I/O error (network glitch?)"; }

    $reason;
}

#
# Begin Main
# 

# Process arguments
my $deployedOne = "";
my $deployedTwo = "";
my $explain = 0;
my $debug = 0;
my $keep = 0;
my $verbose = 0;

my $passExitValue = 0;
my $failExitValue = 1;
my $exitValue = $passExitValue;

map {
    if ($_ =~ /-explain/) { $explain = 1; }
    elsif ($_ =~ /-keep/) { $keep = 1; }
    elsif ($_ =~ /-verbose/) { $verbose = 1; }
    elsif (length($deployedOne) == 0) { $deployedOne = $_; }
    else { $deployedTwo = $_ }
} @ARGV;

die "Could not locate first file to compare: $deployedOne."
  if (!-f $deployedOne);

die "Could not locate second file to compare: $deployedTwo."
  if (!-f $deployedTwo);

my $metaDir = ".META";
my $manifest = "$metaDir/manifest.xml";
my $idManifest_old = "$metaDir/identity_manifest.xml";
my $idManifest_new = "metadata/identityManifest.xml";

# Generate temporary directory for archive extraction.
# By default, directory cleaned up when $tmpDir goes out of scope.
my $tmpDir = tempdir( 'mim_compare_XXXXXX', TMPDIR => 1,
                      CLEANUP => ($keep == 0) );
print "Extracting to temporary directory $tmpDir\n" if ($keep);

# Correct file separators to UNIX-style
$tmpDir =~ s/\\/\//g;

# Make sure temporary directory was created.
die "Failed to create temporary directory $tmpDir: $!" if (!-d $tmpDir);

# Create separate directories for each extraction.
my $extractOne = "$tmpDir/extractOne";
my $extractTwo = "$tmpDir/extractTwo";

# Create a directory in which to extract the metadata for each component.
if (! -d $extractOne)
{
    mkdir($extractOne) ||
      die "Could not create extraction directory $extractOne: $!";
}
else { die "Temporary extraction directory $extractOne unexpectedly exists."; }

if (! -d $extractTwo)
{
    mkdir($extractTwo) ||
      die "Could not create extraction directory $extractTwo: $!";
}
else { die "Temporary extraction directory $extractTwo unexpectedly exists."; }

# Extract the manifests from each deployed component into separate temporary
# directories. Deployed components without manifests are not comparable.
my $manifests_old = [ $manifest, $idManifest_old ];
my $manifests_new = [ $manifest, $idManifest_new ];

my $zipOne = extractZipArchive($deployedOne, $tmpDir);
my $z1COD_old = extractFiles($zipOne, $extractOne, $manifests_old);
my $z1COD_new = extractFiles($zipOne, $extractOne, $manifests_new);
if ( (length($z1COD_old) > 0) && (length($z1COD_new) > 0) )
{
    print "Could not extract manifest files from $deployedOne. Deployed applications without manifests cannot be compared. Use embedIdentityManifest.pl to insert a manifest into $deployedOne.\n" if ($explain);
    exit($failExitValue);
}

my $zipTwo = extractZipArchive($deployedTwo, $tmpDir);
my $z2COD_old = extractFiles($zipTwo, $extractTwo, $manifests_old);
my $z2COD_new = extractFiles($zipTwo, $extractTwo, $manifests_new);
if ( (length($z2COD_old) > 0) && (length($z2COD_new) > 0) )
{
    print "Could not extract manifest files from $deployedTwo. Deployed applications without manifests cannot be compared. Use embedIdentityManifest.pl to insert a manifest into $deployedTwo.\n" if ($explain);
    exit($failExitValue);
}

my $path_to_identity_manifest_one = length($z1COD_old) > 0 ? "$extractOne/$idManifest_new" : "$extractOne/$idManifest_old";
my $path_to_identity_manifest_two = length($z2COD_old) > 0 ? "$extractTwo/$idManifest_new" : "$extractTwo/$idManifest_old";

# Now the manifests should exist on disk. Read them into XML documents.
my $manifestList = [ getXML("$extractOne/$manifest"), 
                     getXML("$extractTwo/$manifest") ];

# Check if identity_manifest is present on the disk
my $idManifestList = [ getXML("$path_to_identity_manifest_one"), 
                       getXML("$path_to_identity_manifest_two") ];

# List of comparison functions. (Perl function references.)
my $tests = [ \&compareMCR, \&compareTargetType, \&compareFileList ];

# Each entry in the results hash is effectively a triplet:
#
#   $results->{ $testName } = ( $result, $reason )
#
# A zero result means the test "failed" -- the two deployed components are 
# not equal according to the criteria of $testName.
#
# All results must be non-zero for the two deployed components to be considered
# equal.

my $results = {};
map {
    my $testResult = $_->($manifestList, $idManifestList, $deployedOne,
                          $deployedTwo, $verbose);
    my $testName = shift( @$testResult );
    $results->{ $testName } = $testResult;
} @$tests;

# Pass or fail? Examine the results to find out. 

my $pass = 1;   # The benefit of the doubt. But Boole is strict taskmaster...
foreach my $test (keys %$results)
{
    $pass = $pass & $results->{$test}->[0];
    
    if (! $pass )
    {
        # Remember failures
        $exitValue = $failExitValue;

        # If we're not explaining, a single failure means game over.
        if (! $explain) { last; }
        print "$results->{$test}->[1].\n";  # The reason. Might be long.
    }
    elsif ($verbose)
    {
        print "$results->{$test}->[1].\n";
    }

} 

my $verity = "are";
$verity = "are not" if ($exitValue == $failExitValue);

# Pass or fail.
print "$deployedOne and $deployedTwo $verity equal.\n"
  if ($explain || $verbose);
exit($exitValue);

#
# End Main
# 

