RetroZilla/build/macosx/universal/unify

#!/usr/bin/perl
# ***** BEGIN LICENSE BLOCK *****
# Version: MPL 1.1/GPL 2.0/LGPL 2.1
#
# The contents of this file are subject to the Mozilla Public License Version
# 1.1 (the "License"); you may not use this file except in compliance with
# the License. You may obtain a copy of the License at
# http://www.mozilla.org/MPL/
#
# Software distributed under the License is distributed on an "AS IS" basis,
# WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
# for the specific language governing rights and limitations under the
# License.
#
# The Original Code is the Mozilla Mac OS X Universal Binary Packaging System
#
# The Initial Developer of the Original Code is Google Inc.
# Portions created by the Initial Developer are Copyright (C) 2006
# the Initial Developer. All Rights Reserved.
#
# Contributor(s):
#  Mark Mentovai <mark@moxienet.com> (Original Author)
#
# Alternatively, the contents of this file may be used under the terms of
# either the GNU General Public License Version 2 or later (the "GPL"), or
# the GNU Lesser General Public License Version 2.1 or later (the "LGPL"),
# in which case the provisions of the GPL or the LGPL are applicable instead
# of those above. If you wish to allow use of your version of this file only
# under the terms of either the GPL or the LGPL, and not to allow others to
# use your version of this file under the terms of the MPL, indicate your
# decision by deleting the provisions above and replace them with the notice
# and other provisions required by the GPL or the LGPL. If you do not delete
# the provisions above, a recipient may use your version of this file under
# the terms of any one of the MPL, the GPL or the LGPL.
#
# ***** END LICENSE BLOCK *****

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>]

=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.

=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 1.1/GPL 2.0/LGPL 2.1.  Your choice

=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);

sub argumentEscape(@);
sub command(@);
sub compareZipArchives($$);
sub complain($$@);
sub copyIfIdentical($$$);
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 path($);
  sub stat($);
  sub statSize($);
}

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

$gDryRun = 0;
$gOnlyOne = 'copy';
$gVerbosity = 2;

Getopt::Long::Configure('pass_through');
GetOptions('dry-run'     => \$gDryRun,
           'only-one=s'  => \$gOnlyOne,
           'verbosity=i' => \$gVerbosity,
           '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;
}

# 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);
    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;
    }
    else {
      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);
    }

    # 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;

  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,
      '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, $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 == 0xcafebabe) {
      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 == 0xfeedface ||
        $magic == 0xcefaedfe ||
        $magic == 0xcafebabe) {
      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'})) {
          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'}.'": '.$!;
      complain(1, 'FileAttrCache::magic: '.$$this{'magicErrMsg'}.' for:',
               $$this{'path'});
      return undef;
    }

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

    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;
      return -1;
    }

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

  # $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];
  }
}