#!/usr/bin/perl
# This Source Code Form is subject to the terms of the Mozilla Public
# License, v. 2.0. If a copy of the MPL was not distributed with this
# file, You can obtain one at http://mozilla.org/MPL/2.0/.

use strict;
use warnings;

=pod

=head1 NAME

B<unify> - Mac OS X universal binary packager

=head1 SYNOPSIS

B<unify>
I<ppc-path>
I<x86-path>
I<universal-path>
[B<--dry-run>]
[B<--only-one> I<action>]
[B<--verbosity> I<level>]
[B<--unify-with-sort> I<regex>]

=head1 DESCRIPTION

I<unify> merges any two architecture-specific files or directory trees
into a single file or tree suitable for use on either architecture as a
"fat" or "universal binary."

Architecture-specific Mach-O files will be merged into fat Mach-O files
using L<lipo(1)>.  Non-Mach-O files in the architecture-specific trees
are compared to ensure that they are equivalent before copying.  Symbolic
links are permitted in the architecture-specific trees and will cause
identical links to be created in the merged tree, provided that the source
links have identical targets.  Directories are processed recursively.

If the architecture-specific source trees contain zip archives (including
jar files) that are not identical according to a byte-for-byte check, they
are still assumed to be equivalent if both archives contain exactly the
same members with identical checksums and sizes.

Behavior when one architecture-specific tree contains files that the other
does not is controlled by the B<--only-one> option.

If Mach-O files cannot be merged using L<lipo(1)>, zip archives are not
equivalent, regular files are not identical, or any other error occurs,
B<unify> will fail with an exit status of 1.  Diagnostic messages are
typically printed to stderr; this behavior can be controlled with the
B<--verbosity> option.

=head1 OPTIONS

=over 5

=item I<ppc-path>

=item I<x86-path>

The paths to directory trees containing PowerPC and x86 builds,
respectively.  I<ppc-path> and I<x86-path> are permitted to contain files
that are already "fat," and only the appropriate architecture's images will
be used.

I<ppc-path> and I<x86-path> are also permitted to both be files, in which
case B<unify> operates solely on those files, and produces an appropriate
merged file at I<target-path>.

=item I<target-path>

The path to the merged file or directory tree.  This path will be created,
and it must not exist prior to running B<unify>.

=item B<--dry-run>

When specified, the commands that would be executed are printed, without
actually executing them.  Note that B<--dry-run> and the equivalent
B<--verbosity> level during "wet" runs may print equivalent commands when
no commands are in fact executed: certain operations are handled internally
within B<unify>, and an approximation of a command that performs a similar
task is printed.

=item B<--only-one> I<action>

Controls handling of files that are only present in one of the two source
trees.  I<action> may be:
  skip - These files are skipped.
  copy - These files are copied from the tree in which they exist.
  fail - When this condition occurs, it is treated as an error.

The default I<action> is copy.

=item B<--verbosity> I<level>

Adjusts the level of loudness of B<unify>.  The possible values for
I<level> are:
  0 - B<unify> never prints anything.
      (Other programs that B<unify> calls may still print messages.)
  1 - Fatal error messages are printed to stderr.
  2 - Nonfatal warnings are printed to stderr.
  3 - Commands are printed to stdout as they are executed.

The default I<level> is 2.

=item B<--unify-with-sort> I<regex>

Allows merging files matching I<regex> that differ only by the ordering
of the lines contained within them. The unified file will have its contents
sorted. This option may be given multiple times to specify multiple
regexes for matching files.

=back

=head1 EXAMPLES

=over 5

=item Create a universal .app bundle from two architecture-specific .app
bundles:

unify --only-one copy ppc/dist/firefox/Firefox.app
  x86/dist/firefox/Firefox.app universal/Firefox.app
  --verbosity 3

=item Merge two identical architecture-specific trees:

unify --only-one fail /usr/local /nfs/x86/usr/local
  /tmp/usrlocal.fat

=back

=head1 REQUIREMENTS

The only esoteric requirement of B<unify> is that the L<lipo(1)> command
be available.  It is present on Mac OS X systems at least as early as
10.3.9, and probably earlier.  Mac OS X 10.4 ("Tiger") or later are
recommended.

=head1 LICENSE

MPL 2.

=head1 AUTHOR

The software was initially written by Mark Mentovai; copyright 2006
Google Inc.

=head1 SEE ALSO

L<cmp(1)>, L<ditto(1)>, L<lipo(1)>

=cut

use Archive::Zip(':ERROR_CODES');
use Errno;
use Fcntl;
use File::Compare;
use File::Copy;
use Getopt::Long;

my (%gConfig, $gDryRun, $gOnlyOne, $gVerbosity, @gSortMatches);

sub argumentEscape(@);
sub command(@);
sub compareZipArchives($$);
sub complain($$@);
sub copyIfIdentical($$$);
sub slurp($);
sub get_sorted($);
sub compare_sorted($$);
sub copyIfIdenticalWhenSorted($$$);
sub createUniqueFile($$);
sub makeUniversal($$$);
sub makeUniversalDirectory($$$);
sub makeUniversalInternal($$$$);
sub makeUniversalFile($$$);
sub usage();
sub readZipCRCs($);

{
  package FileAttrCache;

  sub new($$);

  sub isFat($);
  sub isMachO($);
  sub isZip($);
  sub lIsDir($);
  sub lIsExecutable($);
  sub lIsRegularFile($);
  sub lIsSymLink($);
  sub lstat($);
  sub lstatMode($);
  sub lstatType($);
  sub magic($);
  sub magic2($);
  sub path($);
  sub stat($);
  sub statSize($);
}

%gConfig = (
  'cmd_lipo' => 'lipo',
  'cmd_rm'   => 'rm',
);

$gDryRun = 0;
$gOnlyOne = 'copy';
$gVerbosity = 2;
@gSortMatches = ();

Getopt::Long::Configure('pass_through');
GetOptions('dry-run'           => \$gDryRun,
           'only-one=s'        => \$gOnlyOne,
           'verbosity=i'       => \$gVerbosity,
           'unify-with-sort=s' => \@gSortMatches,
           'config=s'          => \%gConfig); # "hidden" option not in usage()

if (scalar(@ARGV) != 3 || $gVerbosity < 0 || $gVerbosity > 3 ||
    ($gOnlyOne ne 'skip' && $gOnlyOne ne 'copy' && $gOnlyOne ne 'fail')) {
  usage();
  exit(1);
}

if (!makeUniversal($ARGV[0],$ARGV[1],$ARGV[2])) {
  # makeUniversal or something it called will have printed an error.
  exit(1);
}

exit(0);

# argumentEscape(@arguments)
#
# Takes a list of @arguments and makes them shell-safe.
sub argumentEscape(@) {
  my (@arguments);
  @arguments = @_;

  my ($argument, @argumentsOut);
  foreach $argument (@arguments) {
    $argument =~ s%([^A-Za-z0-9_\-/.=+,])%\\$1%g;
    push(@argumentsOut, $argument);
  }

  return @argumentsOut;
}

# command(@arguments)
#
# Runs the specified command by calling system(@arguments).  If $gDryRun
# is true, the command is printed but not executed, and 0 is returned.
# if $gVerbosity is greater than 1, the command is printed before being
# executed.  When the command is executed, the system() return value will
# be returned.  stdout and stderr are left connected for command output.
sub command(@) {
  my (@arguments);
  @arguments = @_;
  if ($gVerbosity >= 3 || $gDryRun) {
    print(join(' ', argumentEscape(@arguments))."\n");
  }
  if ($gDryRun) {
    return 0;
  }
  return system(@arguments);
}

# compareZipArchives($zip1, $zip2)
#
# Given two pathnames to zip archives, determines whether or not they are
# functionally identical.  Returns true if they are, false if they differ in
# some substantial way, and undef if an error occurs.  If the zip files
# differ, diagnostic messages are printed indicating how they differ.
#
# Zip files will differ if any of the members are different as defined by
# readZipCRCs, which consider CRCs, sizes, and file types as stored in the
# file header.  Timestamps are not considered.  Zip files also differ if one
# file contains members that the other one does not.  $gOnlyOne has no
# effect on this behavior.
sub compareZipArchives($$) {
  my ($zip1, $zip2);
  ($zip1, $zip2) = @_;

  my ($CRCHash1, $CRCHash2);
  if (!defined($CRCHash1 = readZipCRCs($zip1))) {
    # readZipCRCs printed an error.
    return undef;
  }
  if (!defined($CRCHash2 = readZipCRCs($zip2))) {
    # readZipCRCs printed an error.
    return undef;
  }

  my (@diffCRCs, @onlyInZip1);
  @diffCRCs = ();
  @onlyInZip1 = ();

  my ($memberName);
  foreach $memberName (keys(%$CRCHash1)) {
    if (!exists($$CRCHash2{$memberName})) {
      # The member is present in $zip1 but not $zip2.
      push(@onlyInZip1, $memberName);
    }
    elsif ($$CRCHash1{$memberName} ne $$CRCHash2{$memberName}) {
      # The member is present in both archives but its CRC or some other
      # other critical attribute isn't identical.
      push(@diffCRCs, $memberName);
    }
    delete($$CRCHash2{$memberName});
  }

  # If any members remain in %CRCHash2, it's because they're not present
  # in $zip1.
  my (@onlyInZip2);
  @onlyInZip2 = keys(%$CRCHash2);

  if (scalar(@onlyInZip1) + scalar(@onlyInZip2) + scalar(@diffCRCs)) {
    complain(1, 'compareZipArchives: zip archives differ:',
             $zip1,
             $zip2);
    if (scalar(@onlyInZip1)) {
      complain(1, 'compareZipArchives: members only in former:',
               @onlyInZip1);
    }
    if (scalar(@onlyInZip2)) {
      complain(1, 'compareZipArchives: members only in latter:',
               @onlyInZip2);
    }
    if (scalar(@diffCRCs)) {
      complain(1, 'compareZipArchives: members differ:',
               @diffCRCs);
    }
    return 0;
  }

  return 1;
}

# complain($severity, $message, @list)
#
# Prints $message to stderr if $gVerbosity allows it for severity level
# $severity.  @list is a list of words that will be shell-escaped and printed
# after $message, one per line, intended to be used, for example, to list
# arguments to a call that failed.
#
# Expected severity levels are 1 for hard errors and 2 for non-fatal warnings.
#
# Always returns false as a convenience, so callers can return complain's
# return value when it is used to signal errors.
sub complain($$@) {
  my ($severity, $message, @list);
  ($severity, $message, @list) = @_;

  if ($gVerbosity >= $severity) {
    print STDERR ($0.': '.$message."\n");

    my ($item);
    while ($item = shift(@list)) {
      print STDERR ('  '.(argumentEscape($item))[0].
                    (scalar(@list)?',':'')."\n");
    }
  }

  return 0;
}

# copyIfIdentical($source1, $source2, $target)
#
# $source1 and $source2 are FileAttrCache objects that are compared, and if
# identical, copied to path string $target.  The comparison is initially
# done as a byte-for-byte comparison, but if the files differ and appear to
# be zip archives, compareZipArchives is called to determine whether
# files that are not byte-for-byte identical are equivalent archives.
#
# Returns true on success, false for files that are not identical or
# equivalent archives, and undef if an error occurs.
#
# One of $source1 and $source2 is permitted to be undef.  In this event,
# whichever source is defined is copied directly to $target without performing
# any comparisons.  This enables the $gOnlyOne = 'copy' mode, which is
# driven by makeUniversalDirectory and makeUniversalInternal.
sub copyIfIdentical($$$) {
  my ($source1, $source2, $target);
  ($source1, $source2, $target) = @_;

  if (!defined($source1)) {
    # If there's only one source file, make it the first file.  Order
    # isn't important here, and this makes it possible to use
    # defined($source2) as the switch, and to always copy from $source1.
    $source1 = $source2;
    $source2 = undef;
  }

  if (defined($source2)) {
    # Only do the comparisons if there are two source files.  If there's
    # only one source file, skip the comparisons and go straight to the
    # copy operation.
    if ($gVerbosity >= 3 || $gDryRun) {
      print('cmp -s '.
            join(' ',argumentEscape($source1->path(), $source2->path()))."\n");
    }
    my ($comparison);
    if (!defined($comparison = compare($source1->path(), $source2->path())) ||
        $comparison == -1) {
      return complain(1, 'copyIfIdentical: compare: '.$!.' while comparing:',
                      $source1->path(),
                      $source2->path());
    }
    elsif ($comparison != 0) {
      my ($zip1, $zip2);
      if (defined($zip1 = $source1->isZip()) &&
          defined($zip2 = $source2->isZip()) &&
          $zip1 && $zip2) {
        my ($zipComparison);
        if (!defined($zipComparison = compareZipArchives($source1->path(),
                                                         $source2->path)) ||
            !$zipComparison) {
          # An error occurred or the zip files aren't sufficiently identical.
          # compareZipArchives will have printed an error message.
          return 0;
        }
        # The zip files were compared successfully, and they both contain
        # all of the same members, and all of their members' CRCs are
        # identical.  For the purposes of this script, the zip files can be
        # treated as identical, so reset $comparison.
        $comparison = 0;
      }
    }
    if ($comparison != 0) {
      return complain(1, 'copyIfIdentical: files differ:',
                      $source1->path(),
                      $source2->path());
    }
  }

  if ($gVerbosity >= 3 || $gDryRun) {
    print('cp '.
          join(' ',argumentEscape($source1->path(), $target))."\n");
  }

  if (!$gDryRun) {
    my ($isExecutable);

    # Set the execute bits (as allowed by the umask) on the new file if any
    # execute bit is set on either old file.
    $isExecutable = $source1->lIsExecutable() ||
                    (defined($source2) && $source2->lIsExecutable());

    if (!createUniqueFile($target, $isExecutable ? 0777 : 0666)) {
      # createUniqueFile printed an error.
      return 0;
    }

    if (!copy($source1->path(), $target)) {
      complain(1, 'copyIfIdentical: copy: '.$!.' while copying',
               $source1->path(),
               $target);
      unlink($target);
      return 0;
    }
  }

  return 1;
}

# slurp($file)
#
# Read the contents of $file into an array and return it.
# Returns undef on error.
sub slurp($) {
  my $file = $_[0];
  open FILE, $file or return undef;
  my @lines = <FILE>;
  close FILE;
  return @lines;
}

# get_sorted($file)
# Get the sorted lines of a file as a list, normalizing a newline on the last line if necessary.
sub get_sorted($) {
  my ($file) = @_;
  my @lines = slurp($file);
  my $lastline = $lines[-1];
  if (!($lastline =~ /\n/)) {
    $lines[-1] = $lastline . "\n";
  }
  return sort(@lines);
}

# compare_sorted($file1, $file2)
#
# Read the contents of both files into arrays, sort the arrays,
# and then compare the two arrays for equality.
#
# Returns 0 if the sorted array contents are equal, or 1 if not.
# Returns undef on error.
sub compare_sorted($$) {
  my ($file1, $file2) = @_;
  my @lines1 = get_sorted($file1);
  my @lines2 = get_sorted($file2);

  return undef if !@lines1 || !@lines2;
  return 1 unless scalar @lines1 == scalar @lines2;

  for (my $i = 0; $i < scalar @lines1; $i++) {
    return 1 if $lines1[$i] ne $lines2[$i];
  }
  return 0;
}

# copyIfIdenticalWhenSorted($source1, $source2, $target)
#
# $source1 and $source2 are FileAttrCache objects that are compared, and if
# identical, copied to path string $target.  The comparison is done by
# sorting the individual lines within the two files and comparing the results.
#
# Returns true on success, false for files that are not equivalent,
# and undef if an error occurs.
sub copyIfIdenticalWhenSorted($$$) {
  my ($source1, $source2, $target);
  ($source1, $source2, $target) = @_;

  if ($gVerbosity >= 3 || $gDryRun) {
    print('cmp -s '.
          join(' ',argumentEscape($source1->path(), $source2->path()))."\n");
  }
  my ($comparison);
  if (!defined($comparison = compare_sorted($source1->path(),
                                            $source2->path())) ||
      $comparison == -1) {
    return complain(1, 'copyIfIdenticalWhenSorted: compare: '.$!
                    .' while comparing:',
                      $source1->path(),
                      $source2->path());
  }
  if ($comparison != 0) {
    return complain(1, 'copyIfIdenticalWhenSorted: files differ:',
                    $source1->path(),
                    $source2->path());
  }

  if ($gVerbosity >= 3 || $gDryRun) {
    print('cp '.
          join(' ',argumentEscape($source1->path(), $target))."\n");
  }

  if (!$gDryRun) {
    my ($isExecutable);

    # Set the execute bits (as allowed by the umask) on the new file if any
    # execute bit is set on either old file.
    $isExecutable = $source1->lIsExecutable() ||
                    (defined($source2) && $source2->lIsExecutable());

    if (!createUniqueFile($target, $isExecutable ? 0777 : 0666)) {
      # createUniqueFile printed an error.
      return 0;
    }

    if (!copy($source1->path(), $target)) {
      complain(1, 'copyIfIdenticalWhenSorted: copy: '.$!
               .' while copying',
               $source1->path(),
               $target);
      unlink($target);
      return 0;
    }
  }

  return 1;
}

# createUniqueFile($path, $mode)
#
# Creates a new plain empty file at pathname $path, provided it does not
# yet exist.  $mode is used as the file mode.  The actual file's mode will
# be modified by the effective umask.  Returns false if the file could
# not be created, setting $! to the error.  An error message is printed
# in the event of failure.
sub createUniqueFile($$) {
  my ($path, $mode);
  ($path, $mode) = @_;

  my ($fh);
  if (!sysopen($fh, $path, O_WRONLY | O_CREAT | O_EXCL, $mode)) {
    return complain(1, 'createUniqueFile: open: '.$!.' for:',
                    $path);
  }
  close($fh);

  return 1;
}

# makeUniversal($pathPPC, $pathX86, $pathTarget)
#
# The top-level call.  $pathPPC, $pathX86, and $pathTarget are strings
# identifying the ppc and x86 files or directories to merge and the location
# to merge them to.  Returns false on failure and true on success.
sub makeUniversal($$$) {
  my ($pathTarget, $pathPPC, $pathX86);
  ($pathPPC, $pathX86, $pathTarget) = @_;

  my ($filePPC, $fileX86);
  $filePPC = FileAttrCache->new($pathPPC);
  $fileX86 = FileAttrCache->new($pathX86);

  return makeUniversalInternal(1, $filePPC, $fileX86, $pathTarget);
}

# makeUniversalDirectory($dirPPC, $dirX86, $dirTarget)
#
# This is part of the heart of recursion.  $dirPPC and $dirX86 are
# FileAttrCache objects designating the source ppc and x86 directories to
# merge into a universal directory at $dirTarget, a string.  For each file
# in $dirPPC and $dirX86, makeUniversalInternal is called.
# makeUniversalInternal will call back into makeUniversalDirectory for
# directories, thus completing the recursion.  If a failure is encountered
# in ths function or in makeUniversalInternal or anything that it calls,
# false is returned, otherwise, true is returned.
#
# If there are files present in one source directory but not both, the
# value of $gOnlyOne controls the behavior.  If $gOnlyOne is 'copy', the
# single source file is copied into $pathTarget.  If it is 'skip', it is
# skipped.  If it is 'fail', such files will trigger makeUniversalDirectory
# to fail.
#
# If either source directory is undef, it is treated as having no files.
# This facilitates deep recursion when entire directories are only present
# in one source when $gOnlyOne = 'copy'.
sub makeUniversalDirectory($$$) {
  my ($dirPPC, $dirX86, $dirTarget);
  ($dirPPC, $dirX86, $dirTarget) = @_;

  my ($dh, @filesPPC, @filesX86);

  @filesPPC = ();
  if (defined($dirPPC)) {
    if (!opendir($dh, $dirPPC->path())) {
      return complain(1, 'makeUniversalDirectory: opendir ppc: '.$!.' for:',
                      $dirPPC->path());
    }
    @filesPPC = readdir($dh);
    closedir($dh);
  }

  @filesX86 = ();
  if (defined($dirX86)) {
    if (!opendir($dh, $dirX86->path())) {
      return complain(1, 'makeUniversalDirectory: opendir x86: '.$!.' for:',
                      $dirX86->path());
     }
    @filesX86 = readdir($dh);
    closedir($dh);
  }

  my (%common, $file, %onlyPPC, %onlyX86);

  %onlyPPC = ();
  foreach $file (@filesPPC) {
    if ($file eq '.' || $file eq '..') {
      next;
    }
    $onlyPPC{$file}=1;
  }

  %common = ();
  %onlyX86 = ();
  foreach $file (@filesX86) {
    if ($file eq '.' || $file eq '..') {
      next;
    }
    if ($onlyPPC{$file}) {
      delete $onlyPPC{$file};
      $common{$file}=1;
    }
    else {
      $onlyX86{$file}=1;
    }
  }

  # First, handle files common to both.
  foreach $file (sort(keys(%common))) {
    if (!makeUniversalInternal(0,
                               FileAttrCache->new($dirPPC->path().'/'.$file),
                               FileAttrCache->new($dirX86->path().'/'.$file),
                               $dirTarget.'/'.$file)) {
      # makeUniversalInternal will have printed an error.
      return 0;
    }
  }

  # Handle files found only in a single directory here.  There are three
  # options, dictated by $gOnlyOne: fail if files are only present in
  # one directory, skip any files only present in one directory, or copy
  # these files straight over to the target directory.  In any event,
  # a message will be printed indicating that the file trees don't match
  # exactly.
  if (keys(%onlyPPC)) {
    complain(($gOnlyOne eq 'fail' ? 1 : 2),
             ($gOnlyOne ne 'fail' ? 'warning: ' : '').
             'makeUniversalDirectory: only in ppc '.
             (argumentEscape($dirPPC->path()))[0].':',
             argumentEscape(keys(%onlyPPC)));
  }

  if (keys(%onlyX86)) {
    complain(($gOnlyOne eq 'fail' ? 1 : 2),
             ($gOnlyOne ne 'fail' ? 'warning: ' : '').
             'makeUniversalDirectory: only in x86 '.
             (argumentEscape($dirX86->path()))[0].':',
             argumentEscape(keys(%onlyX86)));
  }

  if ($gOnlyOne eq 'fail' && (keys(%onlyPPC) || keys(%onlyX86))) {
    # Error message(s) printed above.
    return 0;
  }

  if ($gOnlyOne eq 'copy') {
    foreach $file (sort(keys(%onlyPPC))) {
      if (!makeUniversalInternal(0,
                                 FileAttrCache->new($dirPPC->path().'/'.$file),
                                 undef,
                                 $dirTarget.'/'.$file)) {
        # makeUniversalInternal will have printed an error.
        return 0;
      }
    }

    foreach $file (sort(keys(%onlyX86))) {
      if (!makeUniversalInternal(0,
                                 undef,
                                 FileAttrCache->new($dirX86->path().'/'.$file),
                                 $dirTarget.'/'.$file)) {
        # makeUniversalInternal will have printed an error.
        return 0;
      }
    }
  }

  return 1;
}

# makeUniversalFile($sourcePPC, $sourceX86, $targetPath)
#
# Creates a universal file at pathname $targetPath based on a ppc image at
# $sourcePPC and an x86 image at $sourceX86.  $sourcePPC and $sourceX86 are
# both FileAttrCache objects.  Returns true on success and false on failure.
# On failure, diagnostics will be printed to stderr.
#
# The source files may be either thin Mach-O images of the appropriate
# architecture, or fat Mach-O files that contain images of the appropriate
# architecture.
#
# This function wraps the lipo utility, see lipo(1).
sub makeUniversalFile($$$) {
  my ($sourcePPC, $sourceX86, $targetPath, @tempThinFiles, $thinPPC, $thinX86);
  ($sourcePPC, $sourceX86, $targetPath) = @_;
  $thinPPC = $sourcePPC;
  $thinX86 = $sourceX86;

  @tempThinFiles = ();

  # The source files might already be fat.  They should be thinned out to only
  # contain a single architecture.
 
  my ($isFatPPC, $isFatX86);

  if(!defined($isFatPPC = $sourcePPC->isFat())) {
    # isFat printed its own error
    return 0;
  }
  elsif($isFatPPC) {
    $thinPPC = FileAttrCache->new($targetPath.'.ppc');
    push(@tempThinFiles, $thinPPC->path());
    if (command($gConfig{'cmd_lipo'}, '-thin', 'ppc',
                $sourcePPC->path(), '-output', $thinPPC->path()) != 0) {
      unlink(@tempThinFiles);
      return complain(1, 'lipo thin ppc failed for:',
                      $sourcePPC->path(),
                      $thinPPC->path());
    }
  }

  if(!defined($isFatX86 = $sourceX86->isFat())) {
    # isFat printed its own error
    unlink(@tempThinFiles);
    return 0;
  }
  elsif($isFatX86) {
    $thinX86 = FileAttrCache->new($targetPath.'.x86');
    push(@tempThinFiles, $thinX86->path());
    if (command($gConfig{'cmd_lipo'}, '-thin', 'i386',
                $sourceX86->path(), '-output', $thinX86->path()) != 0) {
      unlink(@tempThinFiles);
      return complain(1, 'lipo thin x86 failed for:',
                      $sourceX86->path(),
                      $thinX86->path());
    }
  }

  # The image for each architecture in the fat file will be aligned on
  # a specific boundary, default 4096 bytes, see lipo(1) -segalign.
  # Since there's no tail-padding, the fat file will consume the least
  # space on disk if the image that comes last exceeds the segment size
  # by the smallest amount.
  #
  # This saves an average of 1kB per fat file over the naive approach of
  # always putting one architecture first: average savings is 2kB per
  # file, but the naive approach would have gotten it right half of the
  # time.

  my ($sizePPC, $sizeX86, $thinPPCForStat, $thinX86ForStat);

  if (!$gDryRun) {
    $thinPPCForStat = $thinPPC;
    $thinX86ForStat = $thinX86;
  }
  else {
    # Normally, fat source files will have been converted into temporary
    # thin files.  During a dry run, that doesn't happen, so fake it up
    # a little bit by always using the source file, fat or thin, for the
    # stat.
    $thinPPCForStat = $sourcePPC;
    $thinX86ForStat = $sourceX86;
  }

  if (!defined($sizePPC = $thinPPCForStat->statSize())) {
    unlink(@tempThinFiles);
    return complain(1, 'stat ppc: '.$!.' for:',
                    $thinPPCForStat->path());
  }
  if (!defined($sizeX86 = $thinX86ForStat->statSize())) {
    unlink(@tempThinFiles);
    return complain(1, 'stat x86: '.$!.' for:',
                    $thinX86ForStat->path());
  }

  $sizePPC = $sizePPC % 4096;
  $sizeX86 = $sizeX86 % 4096;

  my (@thinFiles);

  if ($sizePPC == 0) {
    # PPC image ends on an alignment boundary, there will be no padding before
    # starting the x86 image.
    @thinFiles = ($thinPPC->path(), $thinX86->path());
  }
  elsif ($sizeX86 == 0 || $sizeX86 > $sizePPC) {
    # x86 image ends on an alignment boundary, there will be no padding before
    # starting the PPC image, or the x86 image exceeds its alignment boundary
    # by more than the PPC image, so there will be less padding if the x86
    # comes first.
    @thinFiles = ($thinX86->path(), $thinPPC->path());
  }
  else {
    # PPC image exceeds its alignment boundary by more than the x86 image, so
    # there will be less padding if the PPC comes first.
    @thinFiles = ($thinPPC->path(), $thinX86->path());
  }

  my ($isExecutable);
  $isExecutable = $sourcePPC->lIsExecutable() ||
                  $sourceX86->lIsExecutable();

  if (!$gDryRun) {
    # Ensure that the file does not yet exist.

    # Set the execute bits (as allowed by the umask) on the new file if any
    # execute bit is set on either old file.  Yes, it is possible to have
    # proper Mach-O files without x-bits: think object files (.o) and static
    # archives (.a).
    if (!createUniqueFile($targetPath, $isExecutable ? 0777 : 0666)) {
      # createUniqueFile printed an error.
      unlink(@tempThinFiles);
      return 0;
    }
  }

  # Create the fat file.
  if (command($gConfig{'cmd_lipo'}, '-create', @thinFiles,
              '-output', $targetPath) != 0) {
    unlink(@tempThinFiles, $targetPath);
    return complain(1, 'lipo create fat failed for:',
                    @thinFiles,
                    $targetPath);
  }

  unlink(@tempThinFiles);

  if (!$gDryRun) {
    # lipo seems to think that it's free to set its own file modes that
    # ignore the umask, which is bogus when the rest of this script
    # respects the umask.
    if (!chmod(($isExecutable ? 0777 : 0666) & ~umask(), $targetPath)) {
      complain(1, 'makeUniversalFile: chmod: '.$!.' for',
               $targetPath);
      unlink($targetPath);
      return 0;
    }
  }

  return 1;
}

# makeUniversalInternal($isToplevel, $filePPC, $fileX86, $fileTargetPath)
#
# Given FileAttrCache objects $filePPC and $fileX86, compares filetypes
# and performs the appropriate action to produce a universal file at
# path string $fileTargetPath.  $isToplevel should be true if this is
# the recursive base and false otherwise; this controls cleanup behavior
# (cleanup is only performed at the base, because cleanup itself is
# recursive).
#
# This handles regular files by determining whether they are Mach-O files
# and calling makeUniversalFile if so and copyIfIdentical otherwise.  Symbolic
# links are handled directly in this function by ensuring that the source link
# targets are identical and creating a new link with the same target
# at $fileTargetPath.  Directories are handled by calling
# makeUniversalDirectory.
#
# One of $filePPC and $fileX86 is permitted to be undef.  In that case,
# the defined source file is copied directly to the target if a regular
# file, and symlinked appropriately if a symbolic link.  This facilitates
# use of $gOnlyOne = 'copy', although no $gOnlyOne checks are made in this
# function, they are all handled in makeUniversalDirectory.
#
# Returns true on success.  Returns false on failure, including failures
# in other functions called.
sub makeUniversalInternal($$$$) {
  my ($filePPC, $fileTargetPath, $fileX86, $isToplevel);
  ($isToplevel, $filePPC, $fileX86, $fileTargetPath) = @_;

  my ($typePPC, $typeX86);
  if (defined($filePPC) && !defined($typePPC = $filePPC->lstatType())) {
    return complain(1, 'makeUniversal: lstat ppc: '.$!.' for:',
                    $filePPC->path());
  }
  if (defined($fileX86) && !defined($typeX86 = $fileX86->lstatType())) {
    return complain(1, 'makeUniversal: lstat x86: '.$!.' for:',
                    $fileX86->path());
  }

  if (defined($filePPC) && defined($fileX86) && $typePPC != $typeX86) {
    return complain(1, 'makeUniversal: incompatible types:',
                    $filePPC->path(),
                    $fileX86->path());
  }

  # $aSourceFile will contain a FileAttrCache object that will return
  # the correct type data.  It's used because it's possible for one of
  # the two source files to be undefined (indicating a straight copy).
  my ($aSourceFile);
  if (defined($filePPC)) { 
    $aSourceFile = $filePPC;
  }
  else {
    $aSourceFile = $fileX86;
  }

  if ($aSourceFile->lIsDir()) {
    if ($gVerbosity >= 3 || $gDryRun) {
      print('mkdir '.(argumentEscape($fileTargetPath))[0]."\n");
    }
    if (!$gDryRun && !mkdir($fileTargetPath)) {
      return complain(1, 'makeUniversal: mkdir: '.$!.' for:',
                      $fileTargetPath);
    }

    my ($rv);

    if (!($rv = makeUniversalDirectory($filePPC, $fileX86, $fileTargetPath))) {
      # makeUniversalDirectory printed an error.
      if ($isToplevel) {
        command($gConfig{'cmd_rm'},'-rf','--',$fileTargetPath);
      }
    }
    else {
      # Touch the directory when leaving it.  If unify is being run on an
      # .app bundle, the .app might show up without an icon because the
      # system might have found the .app before it was completely built.
      # Touching it dirties it in LaunchServices' mind.
      if ($gVerbosity >= 3) {
        print('touch '.(argumentEscape($fileTargetPath))[0]."\n");
      }
      utime(undef, undef, $fileTargetPath);
    }

    return $rv;
  }
  elsif ($aSourceFile->lIsSymLink()) {
    my ($linkPPC, $linkX86);
    if (defined($filePPC) && !defined($linkPPC=readlink($filePPC->path()))) {
      return complain(1, 'makeUniversal: readlink ppc: '.$!.' for:',
                      $filePPC->path());
    }
    if (defined($fileX86) && !defined($linkX86=readlink($fileX86->path()))) {
      return complain(1, 'makeUniversal: readlink x86: '.$!.' for:',
                      $fileX86->path());
    }
    if (defined($filePPC) && defined($fileX86) && $linkPPC ne $linkX86) {
      return complain(1, 'makeUniversal: symbolic links differ:',
                      $filePPC->path(),
                      $fileX86->path());
    }

    # $aLink here serves the same purpose as $aSourceFile in the enclosing
    # block: it refers to the target of the symbolic link, whether there
    # is one valid source or two.
    my ($aLink);
    if (defined($linkPPC)) {
      $aLink = $linkPPC;
    }
    else {
      $aLink = $linkX86;
    }

    if ($gVerbosity >= 3 || $gDryRun) {
      print('ln -s '.
            join(' ',argumentEscape($aLink, $fileTargetPath))."\n");
    }
    if (!$gDryRun && !symlink($aLink, $fileTargetPath)) {
      return complain(1, 'makeUniversal: symlink: '.$!.' for:',
                      $aLink,
                      $fileTargetPath);
    }

    return 1;
  }
  elsif($aSourceFile->lIsRegularFile()) {
    my ($machPPC, $machX86, $fileName);
    if (!defined($filePPC) || !defined($fileX86)) {
      # One of the source files isn't present.  The right thing to do is
      # to just copy what does exist straight over, so skip Mach-O checks.
      $machPPC = 0;
      $machX86 = 0;
      if (defined($filePPC)) {
        $fileName = $filePPC;
      } elsif (defined($fileX86)) {
        $fileName = $fileX86;
      } else {
        complain(1, "The file must exist in at least one directory");
        exit(1);
      }
    }
    else {
      # both files exist, pick the name of one.
      $fileName = $fileX86;
      if (!defined($machPPC=$filePPC->isMachO())) {
        return complain(1, 'makeUniversal: isFileMachO ppc failed for:',
                        $filePPC->path());
      }
      if (!defined($machX86=$fileX86->isMachO())) {
        return complain(1, 'makeUniversal: isFileMachO x86 failed for:',
                        $fileX86->path());
      }
    }

    if ($machPPC != $machX86) {
      return complain(1, 'makeUniversal: variant Mach-O attributes:',
                      $filePPC->path(),
                  $fileX86->path());
    }

    if ($machPPC) {
      # makeUniversalFile will print an error if it fails.
      return makeUniversalFile($filePPC, $fileX86, $fileTargetPath);
    }

    if (grep { $fileName->path() =~ m/$_/; } @gSortMatches) {
      # Regular files, but should be compared with sorting first.
      # copyIfIdenticalWhenSorted will print an error if it fails.
      return copyIfIdenticalWhenSorted($filePPC, $fileX86, $fileTargetPath);
    }

    # Regular file.  copyIfIdentical will print an error if it fails.
    return copyIfIdentical($filePPC, $fileX86, $fileTargetPath);
  }

  # Special file, don't know how to handle.
  return complain(1, 'makeUniversal: cannot handle special file:',
                  $filePPC->path(),
                  $fileX86->path());
}

# usage()
#
# Give the user a hand.
sub usage() {
  print STDERR (
"usage: unify <ppc-path> <x86-path> <universal-path>\n".
"            [--dry-run]           (print what would be done)\n".
"            [--only-one <action>] (skip, copy, fail; default=copy)\n".
"            [--verbosity <level>] (0, 1, 2, 3; default=2)\n");
  return;
}

# readZipCRCs($zipFile)
#
# $zipFile is the pathname to a zip file whose directory will be read.
# A reference to a hash is returned, with the member pathnames from the
# zip file as keys, and reasonably unique identifiers as values.  The
# format of the values is not specified exactly, but does include the
# member CRCs and sizes and differentiates between files and directories.
# It specifically does not distinguish between modification times.  On
# failure, prints a message and returns undef.
sub readZipCRCs($) {
  my ($zipFile);
  ($zipFile) = @_;

  my ($ze, $zip);
  $zip = Archive::Zip->new();

  if (($ze = $zip->read($zipFile)) != AZ_OK) {
    complain(1, 'readZipCRCs: read error '.$ze.' for:',
             $zipFile);
    return undef;
  }

  my ($member, %memberCRCs, @memberList);
  %memberCRCs = ();
  @memberList = $zip->members();

  foreach $member (@memberList) {
    # Take a few of the attributes that identify the file and stuff them into
    # the members hash.  Directories will show up with size 0 and crc32 0,
    # so isDirectory() is used to distinguish them from empty files.
    $memberCRCs{$member->fileName()} = join(',', $member->isDirectory() ? 1 : 0,
                                                 $member->uncompressedSize(),
                                                 $member->crc32String());
  }

  return {%memberCRCs};
}

{
  # FileAttrCache allows various attributes about a file to be cached
  # so that if they are needed again after first use, no system calls
  # will be made and the program won't need to hit the disk.

  package FileAttrCache;

  # from /usr/include/mach-o/loader.h
  use constant MH_MAGIC    => 0xfeedface;
  use constant MH_CIGAM    => 0xcefaedfe;
  use constant MH_MAGIC_64 => 0xfeedfacf;
  use constant MH_CIGAM_64 => 0xcffaedfe;

  use Fcntl(':DEFAULT', ':mode');

  # FileAttrCache->new($path)
  #
  # Creates a new FileAttrCache object for the file at path $path and
  # returns it.  The cache is not primed at creation time, values are
  # fetched lazily as they are needed.
  sub new($$) {
    my ($class, $path, $proto, $this);
    ($proto, $path) = @_;
    if (!($class = ref($proto))) {
      $class = $proto;
    }
    $this = {
      'path'        => $path,
      'lstat'       => undef,
      'lstatErrno'  => 0,
      'lstatInit'   => 0,
      'magic'       => undef,
      'magic2'       => undef,
      'magicErrno'  => 0,
      'magicErrMsg' => undef,
      'magicInit'   => 0,
      'stat'        => undef,
      'statErrno'   => 0,
      'statInit'    => 0,
    };
    bless($this, $class);
    return($this);
  }

  # $FileAttrCache->isFat()
  #
  # Returns true if the file is a fat Mach-O file, false if it's not, and
  # undef if an error occurs.  See /usr/include/mach-o/fat.h.
  sub isFat($) {
    my ($magic, $magic2, $this);
    ($this) = @_;

    # magic() caches, there's no separate cache because isFat() doesn't hit
    # the disk other than by calling magic().

    if (!defined($magic = $this->magic())) {
      return undef;
    }
    $magic2 = $this->magic2();

    # We have to sanity check the second four bytes, because Java class
    # files use the same magic number as Mach-O fat binaries.
    # This logic is adapted from file(1), which says that Mach-O uses
    # these bytes to count the number of architectures within, while
    # Java uses it for a version number. Conveniently, there are only
    # 18 labelled Mach-O architectures, and Java's first released
    # class format used the version 43.0.
    if ($magic == 0xcafebabe && $magic2 < 20) {
      return 1;
    }

    return 0;
  }

  # $FileAttrCache->isMachO()
  #
  # Returns true if the file is a Mach-O image (including a fat file), false
  # if it's not, and undef if an error occurs.  See
  # /usr/include/mach-o/loader.h and /usr/include/mach-o/fat.h.
  sub isMachO($) {
    my ($magic, $this);
    ($this) = @_;

    # magic() caches, there's no separate cache because isMachO() doesn't hit
    # the disk other than by calling magic().

    if (!defined($magic = $this->magic())) {
      return undef;
    }

    # Accept Mach-O fat files or Mach-O thin files of either endianness.
    if ($magic == MH_MAGIC ||
        $magic == MH_CIGAM ||
        $magic == MH_MAGIC_64 ||
        $magic == MH_CIGAM_64 ||
        $this->isFat()) {
      return 1;
    }

    return 0;
  }

  # $FileAttrCache->isZip()
  #
  # Returns true if the file is a zip file, false if it's not, and undef if
  # an error occurs.  See http://www.pkware.com/business_and_developers/developer/popups/appnote.txt .
  sub isZip($) {
    my ($magic, $this);
    ($this) = @_;

    # magic() caches, there's no separate cache because isFat() doesn't hit
    # the disk other than by calling magic().

    if (!defined($magic = $this->magic())) {
      return undef;
    }

    if ($magic == 0x504b0304) {
      return 1;
    }

    return 0;
  }

  # $FileAttrCache->lIsExecutable()
  #
  # Wraps $FileAttrCache->lstat(), returning true if the file is has any,
  # execute bit set, false if none are set, or undef if an error occurs.
  # On error, $! is set to lstat's errno.
  sub lIsExecutable($) {
    my ($mode, $this);
    ($this) = @_;

    if (!defined($mode = $this->lstatMode())) {
      return undef;
    }

    return $mode & (S_IXUSR | S_IXGRP | S_IXOTH);
  }

  # $FileAttrCache->lIsDir()
  #
  # Wraps $FileAttrCache->lstat(), returning true if the file is a directory,
  # false if it isn't, or undef if an error occurs.  Because lstat is used,
  # this will return false even if the file is a symlink pointing to a
  # directory.  On error, $! is set to lstat's errno.
  sub lIsDir($) {
    my ($type, $this);
    ($this) = @_;

    if (!defined($type = $this->lstatType())) {
      return undef;
    }

    return S_ISDIR($type);
  }

  # $FileAttrCache->lIsRegularFile()
  #
  # Wraps $FileAttrCache->lstat(), returning true if the file is a regular,
  # file, false if it isn't, or undef if an error occurs.  Because lstat is
  # used, this will return false even if the file is a symlink pointing to a
  # regular file.  On error, $! is set to lstat's errno.
  sub lIsRegularFile($) {
    my ($type, $this);
    ($this) = @_;

    if (!defined($type = $this->lstatType())) {
      return undef;
    }

    return S_ISREG($type);
  }

  # $FileAttrCache->lIsSymLink()
  #
  # Wraps $FileAttrCache->lstat(), returning true if the file is a symbolic,
  # link, false if it isn't, or undef if an error occurs.  On error, $! is
  # set to lstat's errno.
  sub lIsSymLink($) {
    my ($type, $this);
    ($this) = @_;
   
    if (!defined($type = $this->lstatType())) {
      return undef;
    }

    return S_ISLNK($type);
  }

  # $FileAttrCache->lstat()
  #
  # Wraps the lstat system call, providing a cache to speed up multiple
  # lstat calls for the same file.  See lstat(2) and lstat in perlfunc(1).
  sub lstat($) {
    my (@stat, $this);
    ($this) = @_;

    # Use the cached lstat result.
    if ($$this{'lstatInit'}) {
      if (defined($$this{'lstatErrno'})) {
        $! = $$this{'lstatErrno'};
      }
      return @{$$this{'lstat'}};
    }
    $$this{'lstatInit'} = 1;

    if (!(@stat = CORE::lstat($$this{'path'}))) {
      $$this{'lstatErrno'} = $!;
    }

    $$this{'lstat'} = [@stat];
    return @stat;
  }

  # $FileAttrCache->lstatMode()
  #
  # Wraps $FileAttrCache->lstat(), returning the mode bits from the st_mode
  # field, or undef if an error occurs.  On error, $! is set to lstat's
  # errno.
  sub lstatMode($) {
    my (@stat, $this);
    ($this) = @_;

    if (!(@stat = $this->lstat())) {
      return undef;
    }

    return S_IMODE($stat[2]);
  }

  # $FileAttrCache->lstatType()
  #
  # Wraps $FileAttrCache->lstat(), returning the type bits from the st_mode
  # field, or undef if an error occurs.  On error, $! is set to lstat's
  # errno.
  sub lstatType($) {
    my (@stat, $this);
    ($this) = @_;

    if (!(@stat = $this->lstat())) {
      return undef;
    }

    return S_IFMT($stat[2]);
  }

  # $FileAttrCache->magic()
  #
  # Returns the "magic number" for the file by reading its first four bytes
  # as a big-endian unsigned 32-bit integer and returning the result.  If an
  # error occurs, returns undef and prints diagnostic messages to stderr.  If
  # the file is shorter than 32 bits, returns -1.  A cache is provided to
  # speed multiple magic calls for the same file.
  sub magic($) {
    my ($this);
    ($this) = @_;

    # Use the cached magic result.
    if ($$this{'magicInit'}) {
      if (defined($$this{'magicErrno'})) {
        if (defined($$this{'magicErrMsg'})) {
          main::complain(1, 'FileAttrCache::magic: '.$$this{'magicErrMsg'}.' for:',
                   $$this{'path'});
        }
        $! = $$this{'magicErrno'};
      }
      return $$this{'magic'};
    }

    $$this{'magicInit'} = 1;

    my ($fh);
    if (!sysopen($fh, $$this{'path'}, O_RDONLY)) {
      $$this{'magicErrno'} = $!;
      $$this{'magicErrMsg'} = 'open "'.$$this{'path'}.'": '.$!;
      main::complain(1, 'FileAttrCache::magic: '.$$this{'magicErrMsg'}.' for:',
               $$this{'path'});
      return undef;
    }

    $! = 0;
    my ($bytes, $magic, $bytes2, $magic2);
    if (!defined($bytes = sysread($fh, $magic, 4))) {
      $$this{'magicErrno'} = $!;
      $$this{'magicErrMsg'} = 'read "'.$$this{'path'}.'": '.$!;
      main::complain(1, 'FileAttrCache::magic: '.$$this{'magicErrMsg'}.' for:',
               $$this{'path'});
      close($fh);
      return undef;
    }
    else {
      $bytes2 = sysread($fh, $magic2, 4);
    }

    close($fh);

    if ($bytes != 4) {
      # The file is too short, didn't read a magic number.  This isn't really
      # an error.  Return an unlikely value.
      $$this{'magic'} = -1;
      $$this{'magic2'} = -1;
      return -1;
    }
    if ($bytes2 != 4) {
      # File is too short to read a second 4 bytes.
      $magic2 = -1;
    }

    $$this{'magic'} = unpack('N', $magic);
    $$this{'magic2'} = unpack('N', $magic2);
    return $$this{'magic'};
  }

  # $FileAttrCache->magic2()
  #
  # Returns the second four bytes of the file as a 32-bit little endian number.
  # See magic(), above for more info.
  sub magic2($) {
    my ($this);
    ($this) = @_;

    # we do the actual work (and cache it) in magic().
    if (!$$this{'magicInit'}) {
      my $magic = $$this->magic();
    }

    return $$this{'magic2'};
  }

  # $FileAttrCache->path()
  #
  # Returns the file's pathname.
  sub path($) {
    my ($this);
    ($this) = @_;
    return $$this{'path'};
  }

  # $FileAttrCache->stat()
  #
  # Wraps the stat system call, providing a cache to speed up multiple
  # stat calls for the same file.  If lstat() has already been called and
  # the file is not a symbolic link, the cached lstat() result will be used.
  # See stat(2) and lstat in perlfunc(1).
  sub stat($) {
    my (@stat, $this);
    ($this) = @_;

    # Use the cached stat result.
    if ($$this{'statInit'}) {
      if (defined($$this{'statErrno'})) {
        $! = $$this{'statErrno'};
      }
      return @{$$this{'stat'}};
    }

    $$this{'statInit'} = 1;

    # If lstat has already been called, and the file isn't a symbolic link,
    # use the cached lstat result.
    if ($$this{'lstatInit'} && !$$this{'lstatErrno'} &&
        !S_ISLNK(${$$this{'lstat'}}[2])) {
      $$this{'stat'} = $$this{'lstat'};
      return @{$$this{'stat'}};
    }

    if (!(@stat = CORE::stat($$this{'path'}))) {
      $$this{'statErrno'} = $!;
    }

    $$this{'stat'} = [@stat];
    return @stat;
  }

  # $FileAttrCache->statSize()
  #
  # Wraps $FileAttrCache->stat(), returning the st_size field, or undef
  # undef if an error occurs.  On error, $! is set to stat's errno.
  sub statSize($) {
    my (@stat, $this);
    ($this) = @_;

    if (!(@stat = $this->lstat())) {
      return undef;
    }

    return $stat[7];
  }
}