michael@0: #!/usr/bin/perl
michael@0: # This Source Code Form is subject to the terms of the Mozilla Public
michael@0: # License, v. 2.0. If a copy of the MPL was not distributed with this
michael@0: # file, You can obtain one at http://mozilla.org/MPL/2.0/.
michael@0: 
michael@0: use strict;
michael@0: use warnings;
michael@0: 
michael@0: =pod
michael@0: 
michael@0: =head1 NAME
michael@0: 
michael@0: B<unify> - Mac OS X universal binary packager
michael@0: 
michael@0: =head1 SYNOPSIS
michael@0: 
michael@0: B<unify>
michael@0: I<ppc-path>
michael@0: I<x86-path>
michael@0: I<universal-path>
michael@0: [B<--dry-run>]
michael@0: [B<--only-one> I<action>]
michael@0: [B<--verbosity> I<level>]
michael@0: [B<--unify-with-sort> I<regex>]
michael@0: 
michael@0: =head1 DESCRIPTION
michael@0: 
michael@0: I<unify> merges any two architecture-specific files or directory trees
michael@0: into a single file or tree suitable for use on either architecture as a
michael@0: "fat" or "universal binary."
michael@0: 
michael@0: Architecture-specific Mach-O files will be merged into fat Mach-O files
michael@0: using L<lipo(1)>.  Non-Mach-O files in the architecture-specific trees
michael@0: are compared to ensure that they are equivalent before copying.  Symbolic
michael@0: links are permitted in the architecture-specific trees and will cause
michael@0: identical links to be created in the merged tree, provided that the source
michael@0: links have identical targets.  Directories are processed recursively.
michael@0: 
michael@0: If the architecture-specific source trees contain zip archives (including
michael@0: jar files) that are not identical according to a byte-for-byte check, they
michael@0: are still assumed to be equivalent if both archives contain exactly the
michael@0: same members with identical checksums and sizes.
michael@0: 
michael@0: Behavior when one architecture-specific tree contains files that the other
michael@0: does not is controlled by the B<--only-one> option.
michael@0: 
michael@0: If Mach-O files cannot be merged using L<lipo(1)>, zip archives are not
michael@0: equivalent, regular files are not identical, or any other error occurs,
michael@0: B<unify> will fail with an exit status of 1.  Diagnostic messages are
michael@0: typically printed to stderr; this behavior can be controlled with the
michael@0: B<--verbosity> option.
michael@0: 
michael@0: =head1 OPTIONS
michael@0: 
michael@0: =over 5
michael@0: 
michael@0: =item I<ppc-path>
michael@0: 
michael@0: =item I<x86-path>
michael@0: 
michael@0: The paths to directory trees containing PowerPC and x86 builds,
michael@0: respectively.  I<ppc-path> and I<x86-path> are permitted to contain files
michael@0: that are already "fat," and only the appropriate architecture's images will
michael@0: be used.
michael@0: 
michael@0: I<ppc-path> and I<x86-path> are also permitted to both be files, in which
michael@0: case B<unify> operates solely on those files, and produces an appropriate
michael@0: merged file at I<target-path>.
michael@0: 
michael@0: =item I<target-path>
michael@0: 
michael@0: The path to the merged file or directory tree.  This path will be created,
michael@0: and it must not exist prior to running B<unify>.
michael@0: 
michael@0: =item B<--dry-run>
michael@0: 
michael@0: When specified, the commands that would be executed are printed, without
michael@0: actually executing them.  Note that B<--dry-run> and the equivalent
michael@0: B<--verbosity> level during "wet" runs may print equivalent commands when
michael@0: no commands are in fact executed: certain operations are handled internally
michael@0: within B<unify>, and an approximation of a command that performs a similar
michael@0: task is printed.
michael@0: 
michael@0: =item B<--only-one> I<action>
michael@0: 
michael@0: Controls handling of files that are only present in one of the two source
michael@0: trees.  I<action> may be:
michael@0:   skip - These files are skipped.
michael@0:   copy - These files are copied from the tree in which they exist.
michael@0:   fail - When this condition occurs, it is treated as an error.
michael@0: 
michael@0: The default I<action> is copy.
michael@0: 
michael@0: =item B<--verbosity> I<level>
michael@0: 
michael@0: Adjusts the level of loudness of B<unify>.  The possible values for
michael@0: I<level> are:
michael@0:   0 - B<unify> never prints anything.
michael@0:       (Other programs that B<unify> calls may still print messages.)
michael@0:   1 - Fatal error messages are printed to stderr.
michael@0:   2 - Nonfatal warnings are printed to stderr.
michael@0:   3 - Commands are printed to stdout as they are executed.
michael@0: 
michael@0: The default I<level> is 2.
michael@0: 
michael@0: =item B<--unify-with-sort> I<regex>
michael@0: 
michael@0: Allows merging files matching I<regex> that differ only by the ordering
michael@0: of the lines contained within them. The unified file will have its contents
michael@0: sorted. This option may be given multiple times to specify multiple
michael@0: regexes for matching files.
michael@0: 
michael@0: =back
michael@0: 
michael@0: =head1 EXAMPLES
michael@0: 
michael@0: =over 5
michael@0: 
michael@0: =item Create a universal .app bundle from two architecture-specific .app
michael@0: bundles:
michael@0: 
michael@0: unify --only-one copy ppc/dist/firefox/Firefox.app
michael@0:   x86/dist/firefox/Firefox.app universal/Firefox.app
michael@0:   --verbosity 3
michael@0: 
michael@0: =item Merge two identical architecture-specific trees:
michael@0: 
michael@0: unify --only-one fail /usr/local /nfs/x86/usr/local
michael@0:   /tmp/usrlocal.fat
michael@0: 
michael@0: =back
michael@0: 
michael@0: =head1 REQUIREMENTS
michael@0: 
michael@0: The only esoteric requirement of B<unify> is that the L<lipo(1)> command
michael@0: be available.  It is present on Mac OS X systems at least as early as
michael@0: 10.3.9, and probably earlier.  Mac OS X 10.4 ("Tiger") or later are
michael@0: recommended.
michael@0: 
michael@0: =head1 LICENSE
michael@0: 
michael@0: MPL 2.
michael@0: 
michael@0: =head1 AUTHOR
michael@0: 
michael@0: The software was initially written by Mark Mentovai; copyright 2006
michael@0: Google Inc.
michael@0: 
michael@0: =head1 SEE ALSO
michael@0: 
michael@0: L<cmp(1)>, L<ditto(1)>, L<lipo(1)>
michael@0: 
michael@0: =cut
michael@0: 
michael@0: use Archive::Zip(':ERROR_CODES');
michael@0: use Errno;
michael@0: use Fcntl;
michael@0: use File::Compare;
michael@0: use File::Copy;
michael@0: use Getopt::Long;
michael@0: 
michael@0: my (%gConfig, $gDryRun, $gOnlyOne, $gVerbosity, @gSortMatches);
michael@0: 
michael@0: sub argumentEscape(@);
michael@0: sub command(@);
michael@0: sub compareZipArchives($$);
michael@0: sub complain($$@);
michael@0: sub copyIfIdentical($$$);
michael@0: sub slurp($);
michael@0: sub get_sorted($);
michael@0: sub compare_sorted($$);
michael@0: sub copyIfIdenticalWhenSorted($$$);
michael@0: sub createUniqueFile($$);
michael@0: sub makeUniversal($$$);
michael@0: sub makeUniversalDirectory($$$);
michael@0: sub makeUniversalInternal($$$$);
michael@0: sub makeUniversalFile($$$);
michael@0: sub usage();
michael@0: sub readZipCRCs($);
michael@0: 
michael@0: {
michael@0:   package FileAttrCache;
michael@0: 
michael@0:   sub new($$);
michael@0: 
michael@0:   sub isFat($);
michael@0:   sub isMachO($);
michael@0:   sub isZip($);
michael@0:   sub lIsDir($);
michael@0:   sub lIsExecutable($);
michael@0:   sub lIsRegularFile($);
michael@0:   sub lIsSymLink($);
michael@0:   sub lstat($);
michael@0:   sub lstatMode($);
michael@0:   sub lstatType($);
michael@0:   sub magic($);
michael@0:   sub magic2($);
michael@0:   sub path($);
michael@0:   sub stat($);
michael@0:   sub statSize($);
michael@0: }
michael@0: 
michael@0: %gConfig = (
michael@0:   'cmd_lipo' => 'lipo',
michael@0:   'cmd_rm'   => 'rm',
michael@0: );
michael@0: 
michael@0: $gDryRun = 0;
michael@0: $gOnlyOne = 'copy';
michael@0: $gVerbosity = 2;
michael@0: @gSortMatches = ();
michael@0: 
michael@0: Getopt::Long::Configure('pass_through');
michael@0: GetOptions('dry-run'           => \$gDryRun,
michael@0:            'only-one=s'        => \$gOnlyOne,
michael@0:            'verbosity=i'       => \$gVerbosity,
michael@0:            'unify-with-sort=s' => \@gSortMatches,
michael@0:            'config=s'          => \%gConfig); # "hidden" option not in usage()
michael@0: 
michael@0: if (scalar(@ARGV) != 3 || $gVerbosity < 0 || $gVerbosity > 3 ||
michael@0:     ($gOnlyOne ne 'skip' && $gOnlyOne ne 'copy' && $gOnlyOne ne 'fail')) {
michael@0:   usage();
michael@0:   exit(1);
michael@0: }
michael@0: 
michael@0: if (!makeUniversal($ARGV[0],$ARGV[1],$ARGV[2])) {
michael@0:   # makeUniversal or something it called will have printed an error.
michael@0:   exit(1);
michael@0: }
michael@0: 
michael@0: exit(0);
michael@0: 
michael@0: # argumentEscape(@arguments)
michael@0: #
michael@0: # Takes a list of @arguments and makes them shell-safe.
michael@0: sub argumentEscape(@) {
michael@0:   my (@arguments);
michael@0:   @arguments = @_;
michael@0: 
michael@0:   my ($argument, @argumentsOut);
michael@0:   foreach $argument (@arguments) {
michael@0:     $argument =~ s%([^A-Za-z0-9_\-/.=+,])%\\$1%g;
michael@0:     push(@argumentsOut, $argument);
michael@0:   }
michael@0: 
michael@0:   return @argumentsOut;
michael@0: }
michael@0: 
michael@0: # command(@arguments)
michael@0: #
michael@0: # Runs the specified command by calling system(@arguments).  If $gDryRun
michael@0: # is true, the command is printed but not executed, and 0 is returned.
michael@0: # if $gVerbosity is greater than 1, the command is printed before being
michael@0: # executed.  When the command is executed, the system() return value will
michael@0: # be returned.  stdout and stderr are left connected for command output.
michael@0: sub command(@) {
michael@0:   my (@arguments);
michael@0:   @arguments = @_;
michael@0:   if ($gVerbosity >= 3 || $gDryRun) {
michael@0:     print(join(' ', argumentEscape(@arguments))."\n");
michael@0:   }
michael@0:   if ($gDryRun) {
michael@0:     return 0;
michael@0:   }
michael@0:   return system(@arguments);
michael@0: }
michael@0: 
michael@0: # compareZipArchives($zip1, $zip2)
michael@0: #
michael@0: # Given two pathnames to zip archives, determines whether or not they are
michael@0: # functionally identical.  Returns true if they are, false if they differ in
michael@0: # some substantial way, and undef if an error occurs.  If the zip files
michael@0: # differ, diagnostic messages are printed indicating how they differ.
michael@0: #
michael@0: # Zip files will differ if any of the members are different as defined by
michael@0: # readZipCRCs, which consider CRCs, sizes, and file types as stored in the
michael@0: # file header.  Timestamps are not considered.  Zip files also differ if one
michael@0: # file contains members that the other one does not.  $gOnlyOne has no
michael@0: # effect on this behavior.
michael@0: sub compareZipArchives($$) {
michael@0:   my ($zip1, $zip2);
michael@0:   ($zip1, $zip2) = @_;
michael@0: 
michael@0:   my ($CRCHash1, $CRCHash2);
michael@0:   if (!defined($CRCHash1 = readZipCRCs($zip1))) {
michael@0:     # readZipCRCs printed an error.
michael@0:     return undef;
michael@0:   }
michael@0:   if (!defined($CRCHash2 = readZipCRCs($zip2))) {
michael@0:     # readZipCRCs printed an error.
michael@0:     return undef;
michael@0:   }
michael@0: 
michael@0:   my (@diffCRCs, @onlyInZip1);
michael@0:   @diffCRCs = ();
michael@0:   @onlyInZip1 = ();
michael@0: 
michael@0:   my ($memberName);
michael@0:   foreach $memberName (keys(%$CRCHash1)) {
michael@0:     if (!exists($$CRCHash2{$memberName})) {
michael@0:       # The member is present in $zip1 but not $zip2.
michael@0:       push(@onlyInZip1, $memberName);
michael@0:     }
michael@0:     elsif ($$CRCHash1{$memberName} ne $$CRCHash2{$memberName}) {
michael@0:       # The member is present in both archives but its CRC or some other
michael@0:       # other critical attribute isn't identical.
michael@0:       push(@diffCRCs, $memberName);
michael@0:     }
michael@0:     delete($$CRCHash2{$memberName});
michael@0:   }
michael@0: 
michael@0:   # If any members remain in %CRCHash2, it's because they're not present
michael@0:   # in $zip1.
michael@0:   my (@onlyInZip2);
michael@0:   @onlyInZip2 = keys(%$CRCHash2);
michael@0: 
michael@0:   if (scalar(@onlyInZip1) + scalar(@onlyInZip2) + scalar(@diffCRCs)) {
michael@0:     complain(1, 'compareZipArchives: zip archives differ:',
michael@0:              $zip1,
michael@0:              $zip2);
michael@0:     if (scalar(@onlyInZip1)) {
michael@0:       complain(1, 'compareZipArchives: members only in former:',
michael@0:                @onlyInZip1);
michael@0:     }
michael@0:     if (scalar(@onlyInZip2)) {
michael@0:       complain(1, 'compareZipArchives: members only in latter:',
michael@0:                @onlyInZip2);
michael@0:     }
michael@0:     if (scalar(@diffCRCs)) {
michael@0:       complain(1, 'compareZipArchives: members differ:',
michael@0:                @diffCRCs);
michael@0:     }
michael@0:     return 0;
michael@0:   }
michael@0: 
michael@0:   return 1;
michael@0: }
michael@0: 
michael@0: # complain($severity, $message, @list)
michael@0: #
michael@0: # Prints $message to stderr if $gVerbosity allows it for severity level
michael@0: # $severity.  @list is a list of words that will be shell-escaped and printed
michael@0: # after $message, one per line, intended to be used, for example, to list
michael@0: # arguments to a call that failed.
michael@0: #
michael@0: # Expected severity levels are 1 for hard errors and 2 for non-fatal warnings.
michael@0: #
michael@0: # Always returns false as a convenience, so callers can return complain's
michael@0: # return value when it is used to signal errors.
michael@0: sub complain($$@) {
michael@0:   my ($severity, $message, @list);
michael@0:   ($severity, $message, @list) = @_;
michael@0: 
michael@0:   if ($gVerbosity >= $severity) {
michael@0:     print STDERR ($0.': '.$message."\n");
michael@0: 
michael@0:     my ($item);
michael@0:     while ($item = shift(@list)) {
michael@0:       print STDERR ('  '.(argumentEscape($item))[0].
michael@0:                     (scalar(@list)?',':'')."\n");
michael@0:     }
michael@0:   }
michael@0: 
michael@0:   return 0;
michael@0: }
michael@0: 
michael@0: # copyIfIdentical($source1, $source2, $target)
michael@0: #
michael@0: # $source1 and $source2 are FileAttrCache objects that are compared, and if
michael@0: # identical, copied to path string $target.  The comparison is initially
michael@0: # done as a byte-for-byte comparison, but if the files differ and appear to
michael@0: # be zip archives, compareZipArchives is called to determine whether
michael@0: # files that are not byte-for-byte identical are equivalent archives.
michael@0: #
michael@0: # Returns true on success, false for files that are not identical or
michael@0: # equivalent archives, and undef if an error occurs.
michael@0: #
michael@0: # One of $source1 and $source2 is permitted to be undef.  In this event,
michael@0: # whichever source is defined is copied directly to $target without performing
michael@0: # any comparisons.  This enables the $gOnlyOne = 'copy' mode, which is
michael@0: # driven by makeUniversalDirectory and makeUniversalInternal.
michael@0: sub copyIfIdentical($$$) {
michael@0:   my ($source1, $source2, $target);
michael@0:   ($source1, $source2, $target) = @_;
michael@0: 
michael@0:   if (!defined($source1)) {
michael@0:     # If there's only one source file, make it the first file.  Order
michael@0:     # isn't important here, and this makes it possible to use
michael@0:     # defined($source2) as the switch, and to always copy from $source1.
michael@0:     $source1 = $source2;
michael@0:     $source2 = undef;
michael@0:   }
michael@0: 
michael@0:   if (defined($source2)) {
michael@0:     # Only do the comparisons if there are two source files.  If there's
michael@0:     # only one source file, skip the comparisons and go straight to the
michael@0:     # copy operation.
michael@0:     if ($gVerbosity >= 3 || $gDryRun) {
michael@0:       print('cmp -s '.
michael@0:             join(' ',argumentEscape($source1->path(), $source2->path()))."\n");
michael@0:     }
michael@0:     my ($comparison);
michael@0:     if (!defined($comparison = compare($source1->path(), $source2->path())) ||
michael@0:         $comparison == -1) {
michael@0:       return complain(1, 'copyIfIdentical: compare: '.$!.' while comparing:',
michael@0:                       $source1->path(),
michael@0:                       $source2->path());
michael@0:     }
michael@0:     elsif ($comparison != 0) {
michael@0:       my ($zip1, $zip2);
michael@0:       if (defined($zip1 = $source1->isZip()) &&
michael@0:           defined($zip2 = $source2->isZip()) &&
michael@0:           $zip1 && $zip2) {
michael@0:         my ($zipComparison);
michael@0:         if (!defined($zipComparison = compareZipArchives($source1->path(),
michael@0:                                                          $source2->path)) ||
michael@0:             !$zipComparison) {
michael@0:           # An error occurred or the zip files aren't sufficiently identical.
michael@0:           # compareZipArchives will have printed an error message.
michael@0:           return 0;
michael@0:         }
michael@0:         # The zip files were compared successfully, and they both contain
michael@0:         # all of the same members, and all of their members' CRCs are
michael@0:         # identical.  For the purposes of this script, the zip files can be
michael@0:         # treated as identical, so reset $comparison.
michael@0:         $comparison = 0;
michael@0:       }
michael@0:     }
michael@0:     if ($comparison != 0) {
michael@0:       return complain(1, 'copyIfIdentical: files differ:',
michael@0:                       $source1->path(),
michael@0:                       $source2->path());
michael@0:     }
michael@0:   }
michael@0: 
michael@0:   if ($gVerbosity >= 3 || $gDryRun) {
michael@0:     print('cp '.
michael@0:           join(' ',argumentEscape($source1->path(), $target))."\n");
michael@0:   }
michael@0: 
michael@0:   if (!$gDryRun) {
michael@0:     my ($isExecutable);
michael@0: 
michael@0:     # Set the execute bits (as allowed by the umask) on the new file if any
michael@0:     # execute bit is set on either old file.
michael@0:     $isExecutable = $source1->lIsExecutable() ||
michael@0:                     (defined($source2) && $source2->lIsExecutable());
michael@0: 
michael@0:     if (!createUniqueFile($target, $isExecutable ? 0777 : 0666)) {
michael@0:       # createUniqueFile printed an error.
michael@0:       return 0;
michael@0:     }
michael@0: 
michael@0:     if (!copy($source1->path(), $target)) {
michael@0:       complain(1, 'copyIfIdentical: copy: '.$!.' while copying',
michael@0:                $source1->path(),
michael@0:                $target);
michael@0:       unlink($target);
michael@0:       return 0;
michael@0:     }
michael@0:   }
michael@0: 
michael@0:   return 1;
michael@0: }
michael@0: 
michael@0: # slurp($file)
michael@0: #
michael@0: # Read the contents of $file into an array and return it.
michael@0: # Returns undef on error.
michael@0: sub slurp($) {
michael@0:   my $file = $_[0];
michael@0:   open FILE, $file or return undef;
michael@0:   my @lines = <FILE>;
michael@0:   close FILE;
michael@0:   return @lines;
michael@0: }
michael@0: 
michael@0: # get_sorted($file)
michael@0: # Get the sorted lines of a file as a list, normalizing a newline on the last line if necessary.
michael@0: sub get_sorted($) {
michael@0:   my ($file) = @_;
michael@0:   my @lines = slurp($file);
michael@0:   my $lastline = $lines[-1];
michael@0:   if (!($lastline =~ /\n/)) {
michael@0:     $lines[-1] = $lastline . "\n";
michael@0:   }
michael@0:   return sort(@lines);
michael@0: }
michael@0: 
michael@0: # compare_sorted($file1, $file2)
michael@0: #
michael@0: # Read the contents of both files into arrays, sort the arrays,
michael@0: # and then compare the two arrays for equality.
michael@0: #
michael@0: # Returns 0 if the sorted array contents are equal, or 1 if not.
michael@0: # Returns undef on error.
michael@0: sub compare_sorted($$) {
michael@0:   my ($file1, $file2) = @_;
michael@0:   my @lines1 = get_sorted($file1);
michael@0:   my @lines2 = get_sorted($file2);
michael@0: 
michael@0:   return undef if !@lines1 || !@lines2;
michael@0:   return 1 unless scalar @lines1 == scalar @lines2;
michael@0: 
michael@0:   for (my $i = 0; $i < scalar @lines1; $i++) {
michael@0:     return 1 if $lines1[$i] ne $lines2[$i];
michael@0:   }
michael@0:   return 0;
michael@0: }
michael@0: 
michael@0: # copyIfIdenticalWhenSorted($source1, $source2, $target)
michael@0: #
michael@0: # $source1 and $source2 are FileAttrCache objects that are compared, and if
michael@0: # identical, copied to path string $target.  The comparison is done by
michael@0: # sorting the individual lines within the two files and comparing the results.
michael@0: #
michael@0: # Returns true on success, false for files that are not equivalent,
michael@0: # and undef if an error occurs.
michael@0: sub copyIfIdenticalWhenSorted($$$) {
michael@0:   my ($source1, $source2, $target);
michael@0:   ($source1, $source2, $target) = @_;
michael@0: 
michael@0:   if ($gVerbosity >= 3 || $gDryRun) {
michael@0:     print('cmp -s '.
michael@0:           join(' ',argumentEscape($source1->path(), $source2->path()))."\n");
michael@0:   }
michael@0:   my ($comparison);
michael@0:   if (!defined($comparison = compare_sorted($source1->path(),
michael@0:                                             $source2->path())) ||
michael@0:       $comparison == -1) {
michael@0:     return complain(1, 'copyIfIdenticalWhenSorted: compare: '.$!
michael@0:                     .' while comparing:',
michael@0:                       $source1->path(),
michael@0:                       $source2->path());
michael@0:   }
michael@0:   if ($comparison != 0) {
michael@0:     return complain(1, 'copyIfIdenticalWhenSorted: files differ:',
michael@0:                     $source1->path(),
michael@0:                     $source2->path());
michael@0:   }
michael@0: 
michael@0:   if ($gVerbosity >= 3 || $gDryRun) {
michael@0:     print('cp '.
michael@0:           join(' ',argumentEscape($source1->path(), $target))."\n");
michael@0:   }
michael@0: 
michael@0:   if (!$gDryRun) {
michael@0:     my ($isExecutable);
michael@0: 
michael@0:     # Set the execute bits (as allowed by the umask) on the new file if any
michael@0:     # execute bit is set on either old file.
michael@0:     $isExecutable = $source1->lIsExecutable() ||
michael@0:                     (defined($source2) && $source2->lIsExecutable());
michael@0: 
michael@0:     if (!createUniqueFile($target, $isExecutable ? 0777 : 0666)) {
michael@0:       # createUniqueFile printed an error.
michael@0:       return 0;
michael@0:     }
michael@0: 
michael@0:     if (!copy($source1->path(), $target)) {
michael@0:       complain(1, 'copyIfIdenticalWhenSorted: copy: '.$!
michael@0:                .' while copying',
michael@0:                $source1->path(),
michael@0:                $target);
michael@0:       unlink($target);
michael@0:       return 0;
michael@0:     }
michael@0:   }
michael@0: 
michael@0:   return 1;
michael@0: }
michael@0: 
michael@0: # createUniqueFile($path, $mode)
michael@0: #
michael@0: # Creates a new plain empty file at pathname $path, provided it does not
michael@0: # yet exist.  $mode is used as the file mode.  The actual file's mode will
michael@0: # be modified by the effective umask.  Returns false if the file could
michael@0: # not be created, setting $! to the error.  An error message is printed
michael@0: # in the event of failure.
michael@0: sub createUniqueFile($$) {
michael@0:   my ($path, $mode);
michael@0:   ($path, $mode) = @_;
michael@0: 
michael@0:   my ($fh);
michael@0:   if (!sysopen($fh, $path, O_WRONLY | O_CREAT | O_EXCL, $mode)) {
michael@0:     return complain(1, 'createUniqueFile: open: '.$!.' for:',
michael@0:                     $path);
michael@0:   }
michael@0:   close($fh);
michael@0: 
michael@0:   return 1;
michael@0: }
michael@0: 
michael@0: # makeUniversal($pathPPC, $pathX86, $pathTarget)
michael@0: #
michael@0: # The top-level call.  $pathPPC, $pathX86, and $pathTarget are strings
michael@0: # identifying the ppc and x86 files or directories to merge and the location
michael@0: # to merge them to.  Returns false on failure and true on success.
michael@0: sub makeUniversal($$$) {
michael@0:   my ($pathTarget, $pathPPC, $pathX86);
michael@0:   ($pathPPC, $pathX86, $pathTarget) = @_;
michael@0: 
michael@0:   my ($filePPC, $fileX86);
michael@0:   $filePPC = FileAttrCache->new($pathPPC);
michael@0:   $fileX86 = FileAttrCache->new($pathX86);
michael@0: 
michael@0:   return makeUniversalInternal(1, $filePPC, $fileX86, $pathTarget);
michael@0: }
michael@0: 
michael@0: # makeUniversalDirectory($dirPPC, $dirX86, $dirTarget)
michael@0: #
michael@0: # This is part of the heart of recursion.  $dirPPC and $dirX86 are
michael@0: # FileAttrCache objects designating the source ppc and x86 directories to
michael@0: # merge into a universal directory at $dirTarget, a string.  For each file
michael@0: # in $dirPPC and $dirX86, makeUniversalInternal is called.
michael@0: # makeUniversalInternal will call back into makeUniversalDirectory for
michael@0: # directories, thus completing the recursion.  If a failure is encountered
michael@0: # in ths function or in makeUniversalInternal or anything that it calls,
michael@0: # false is returned, otherwise, true is returned.
michael@0: #
michael@0: # If there are files present in one source directory but not both, the
michael@0: # value of $gOnlyOne controls the behavior.  If $gOnlyOne is 'copy', the
michael@0: # single source file is copied into $pathTarget.  If it is 'skip', it is
michael@0: # skipped.  If it is 'fail', such files will trigger makeUniversalDirectory
michael@0: # to fail.
michael@0: #
michael@0: # If either source directory is undef, it is treated as having no files.
michael@0: # This facilitates deep recursion when entire directories are only present
michael@0: # in one source when $gOnlyOne = 'copy'.
michael@0: sub makeUniversalDirectory($$$) {
michael@0:   my ($dirPPC, $dirX86, $dirTarget);
michael@0:   ($dirPPC, $dirX86, $dirTarget) = @_;
michael@0: 
michael@0:   my ($dh, @filesPPC, @filesX86);
michael@0: 
michael@0:   @filesPPC = ();
michael@0:   if (defined($dirPPC)) {
michael@0:     if (!opendir($dh, $dirPPC->path())) {
michael@0:       return complain(1, 'makeUniversalDirectory: opendir ppc: '.$!.' for:',
michael@0:                       $dirPPC->path());
michael@0:     }
michael@0:     @filesPPC = readdir($dh);
michael@0:     closedir($dh);
michael@0:   }
michael@0: 
michael@0:   @filesX86 = ();
michael@0:   if (defined($dirX86)) {
michael@0:     if (!opendir($dh, $dirX86->path())) {
michael@0:       return complain(1, 'makeUniversalDirectory: opendir x86: '.$!.' for:',
michael@0:                       $dirX86->path());
michael@0:      }
michael@0:     @filesX86 = readdir($dh);
michael@0:     closedir($dh);
michael@0:   }
michael@0: 
michael@0:   my (%common, $file, %onlyPPC, %onlyX86);
michael@0: 
michael@0:   %onlyPPC = ();
michael@0:   foreach $file (@filesPPC) {
michael@0:     if ($file eq '.' || $file eq '..') {
michael@0:       next;
michael@0:     }
michael@0:     $onlyPPC{$file}=1;
michael@0:   }
michael@0: 
michael@0:   %common = ();
michael@0:   %onlyX86 = ();
michael@0:   foreach $file (@filesX86) {
michael@0:     if ($file eq '.' || $file eq '..') {
michael@0:       next;
michael@0:     }
michael@0:     if ($onlyPPC{$file}) {
michael@0:       delete $onlyPPC{$file};
michael@0:       $common{$file}=1;
michael@0:     }
michael@0:     else {
michael@0:       $onlyX86{$file}=1;
michael@0:     }
michael@0:   }
michael@0: 
michael@0:   # First, handle files common to both.
michael@0:   foreach $file (sort(keys(%common))) {
michael@0:     if (!makeUniversalInternal(0,
michael@0:                                FileAttrCache->new($dirPPC->path().'/'.$file),
michael@0:                                FileAttrCache->new($dirX86->path().'/'.$file),
michael@0:                                $dirTarget.'/'.$file)) {
michael@0:       # makeUniversalInternal will have printed an error.
michael@0:       return 0;
michael@0:     }
michael@0:   }
michael@0: 
michael@0:   # Handle files found only in a single directory here.  There are three
michael@0:   # options, dictated by $gOnlyOne: fail if files are only present in
michael@0:   # one directory, skip any files only present in one directory, or copy
michael@0:   # these files straight over to the target directory.  In any event,
michael@0:   # a message will be printed indicating that the file trees don't match
michael@0:   # exactly.
michael@0:   if (keys(%onlyPPC)) {
michael@0:     complain(($gOnlyOne eq 'fail' ? 1 : 2),
michael@0:              ($gOnlyOne ne 'fail' ? 'warning: ' : '').
michael@0:              'makeUniversalDirectory: only in ppc '.
michael@0:              (argumentEscape($dirPPC->path()))[0].':',
michael@0:              argumentEscape(keys(%onlyPPC)));
michael@0:   }
michael@0: 
michael@0:   if (keys(%onlyX86)) {
michael@0:     complain(($gOnlyOne eq 'fail' ? 1 : 2),
michael@0:              ($gOnlyOne ne 'fail' ? 'warning: ' : '').
michael@0:              'makeUniversalDirectory: only in x86 '.
michael@0:              (argumentEscape($dirX86->path()))[0].':',
michael@0:              argumentEscape(keys(%onlyX86)));
michael@0:   }
michael@0: 
michael@0:   if ($gOnlyOne eq 'fail' && (keys(%onlyPPC) || keys(%onlyX86))) {
michael@0:     # Error message(s) printed above.
michael@0:     return 0;
michael@0:   }
michael@0: 
michael@0:   if ($gOnlyOne eq 'copy') {
michael@0:     foreach $file (sort(keys(%onlyPPC))) {
michael@0:       if (!makeUniversalInternal(0,
michael@0:                                  FileAttrCache->new($dirPPC->path().'/'.$file),
michael@0:                                  undef,
michael@0:                                  $dirTarget.'/'.$file)) {
michael@0:         # makeUniversalInternal will have printed an error.
michael@0:         return 0;
michael@0:       }
michael@0:     }
michael@0: 
michael@0:     foreach $file (sort(keys(%onlyX86))) {
michael@0:       if (!makeUniversalInternal(0,
michael@0:                                  undef,
michael@0:                                  FileAttrCache->new($dirX86->path().'/'.$file),
michael@0:                                  $dirTarget.'/'.$file)) {
michael@0:         # makeUniversalInternal will have printed an error.
michael@0:         return 0;
michael@0:       }
michael@0:     }
michael@0:   }
michael@0: 
michael@0:   return 1;
michael@0: }
michael@0: 
michael@0: # makeUniversalFile($sourcePPC, $sourceX86, $targetPath)
michael@0: #
michael@0: # Creates a universal file at pathname $targetPath based on a ppc image at
michael@0: # $sourcePPC and an x86 image at $sourceX86.  $sourcePPC and $sourceX86 are
michael@0: # both FileAttrCache objects.  Returns true on success and false on failure.
michael@0: # On failure, diagnostics will be printed to stderr.
michael@0: #
michael@0: # The source files may be either thin Mach-O images of the appropriate
michael@0: # architecture, or fat Mach-O files that contain images of the appropriate
michael@0: # architecture.
michael@0: #
michael@0: # This function wraps the lipo utility, see lipo(1).
michael@0: sub makeUniversalFile($$$) {
michael@0:   my ($sourcePPC, $sourceX86, $targetPath, @tempThinFiles, $thinPPC, $thinX86);
michael@0:   ($sourcePPC, $sourceX86, $targetPath) = @_;
michael@0:   $thinPPC = $sourcePPC;
michael@0:   $thinX86 = $sourceX86;
michael@0: 
michael@0:   @tempThinFiles = ();
michael@0: 
michael@0:   # The source files might already be fat.  They should be thinned out to only
michael@0:   # contain a single architecture.
michael@0:  
michael@0:   my ($isFatPPC, $isFatX86);
michael@0: 
michael@0:   if(!defined($isFatPPC = $sourcePPC->isFat())) {
michael@0:     # isFat printed its own error
michael@0:     return 0;
michael@0:   }
michael@0:   elsif($isFatPPC) {
michael@0:     $thinPPC = FileAttrCache->new($targetPath.'.ppc');
michael@0:     push(@tempThinFiles, $thinPPC->path());
michael@0:     if (command($gConfig{'cmd_lipo'}, '-thin', 'ppc',
michael@0:                 $sourcePPC->path(), '-output', $thinPPC->path()) != 0) {
michael@0:       unlink(@tempThinFiles);
michael@0:       return complain(1, 'lipo thin ppc failed for:',
michael@0:                       $sourcePPC->path(),
michael@0:                       $thinPPC->path());
michael@0:     }
michael@0:   }
michael@0: 
michael@0:   if(!defined($isFatX86 = $sourceX86->isFat())) {
michael@0:     # isFat printed its own error
michael@0:     unlink(@tempThinFiles);
michael@0:     return 0;
michael@0:   }
michael@0:   elsif($isFatX86) {
michael@0:     $thinX86 = FileAttrCache->new($targetPath.'.x86');
michael@0:     push(@tempThinFiles, $thinX86->path());
michael@0:     if (command($gConfig{'cmd_lipo'}, '-thin', 'i386',
michael@0:                 $sourceX86->path(), '-output', $thinX86->path()) != 0) {
michael@0:       unlink(@tempThinFiles);
michael@0:       return complain(1, 'lipo thin x86 failed for:',
michael@0:                       $sourceX86->path(),
michael@0:                       $thinX86->path());
michael@0:     }
michael@0:   }
michael@0: 
michael@0:   # The image for each architecture in the fat file will be aligned on
michael@0:   # a specific boundary, default 4096 bytes, see lipo(1) -segalign.
michael@0:   # Since there's no tail-padding, the fat file will consume the least
michael@0:   # space on disk if the image that comes last exceeds the segment size
michael@0:   # by the smallest amount.
michael@0:   #
michael@0:   # This saves an average of 1kB per fat file over the naive approach of
michael@0:   # always putting one architecture first: average savings is 2kB per
michael@0:   # file, but the naive approach would have gotten it right half of the
michael@0:   # time.
michael@0: 
michael@0:   my ($sizePPC, $sizeX86, $thinPPCForStat, $thinX86ForStat);
michael@0: 
michael@0:   if (!$gDryRun) {
michael@0:     $thinPPCForStat = $thinPPC;
michael@0:     $thinX86ForStat = $thinX86;
michael@0:   }
michael@0:   else {
michael@0:     # Normally, fat source files will have been converted into temporary
michael@0:     # thin files.  During a dry run, that doesn't happen, so fake it up
michael@0:     # a little bit by always using the source file, fat or thin, for the
michael@0:     # stat.
michael@0:     $thinPPCForStat = $sourcePPC;
michael@0:     $thinX86ForStat = $sourceX86;
michael@0:   }
michael@0: 
michael@0:   if (!defined($sizePPC = $thinPPCForStat->statSize())) {
michael@0:     unlink(@tempThinFiles);
michael@0:     return complain(1, 'stat ppc: '.$!.' for:',
michael@0:                     $thinPPCForStat->path());
michael@0:   }
michael@0:   if (!defined($sizeX86 = $thinX86ForStat->statSize())) {
michael@0:     unlink(@tempThinFiles);
michael@0:     return complain(1, 'stat x86: '.$!.' for:',
michael@0:                     $thinX86ForStat->path());
michael@0:   }
michael@0: 
michael@0:   $sizePPC = $sizePPC % 4096;
michael@0:   $sizeX86 = $sizeX86 % 4096;
michael@0: 
michael@0:   my (@thinFiles);
michael@0: 
michael@0:   if ($sizePPC == 0) {
michael@0:     # PPC image ends on an alignment boundary, there will be no padding before
michael@0:     # starting the x86 image.
michael@0:     @thinFiles = ($thinPPC->path(), $thinX86->path());
michael@0:   }
michael@0:   elsif ($sizeX86 == 0 || $sizeX86 > $sizePPC) {
michael@0:     # x86 image ends on an alignment boundary, there will be no padding before
michael@0:     # starting the PPC image, or the x86 image exceeds its alignment boundary
michael@0:     # by more than the PPC image, so there will be less padding if the x86
michael@0:     # comes first.
michael@0:     @thinFiles = ($thinX86->path(), $thinPPC->path());
michael@0:   }
michael@0:   else {
michael@0:     # PPC image exceeds its alignment boundary by more than the x86 image, so
michael@0:     # there will be less padding if the PPC comes first.
michael@0:     @thinFiles = ($thinPPC->path(), $thinX86->path());
michael@0:   }
michael@0: 
michael@0:   my ($isExecutable);
michael@0:   $isExecutable = $sourcePPC->lIsExecutable() ||
michael@0:                   $sourceX86->lIsExecutable();
michael@0: 
michael@0:   if (!$gDryRun) {
michael@0:     # Ensure that the file does not yet exist.
michael@0: 
michael@0:     # Set the execute bits (as allowed by the umask) on the new file if any
michael@0:     # execute bit is set on either old file.  Yes, it is possible to have
michael@0:     # proper Mach-O files without x-bits: think object files (.o) and static
michael@0:     # archives (.a).
michael@0:     if (!createUniqueFile($targetPath, $isExecutable ? 0777 : 0666)) {
michael@0:       # createUniqueFile printed an error.
michael@0:       unlink(@tempThinFiles);
michael@0:       return 0;
michael@0:     }
michael@0:   }
michael@0: 
michael@0:   # Create the fat file.
michael@0:   if (command($gConfig{'cmd_lipo'}, '-create', @thinFiles,
michael@0:               '-output', $targetPath) != 0) {
michael@0:     unlink(@tempThinFiles, $targetPath);
michael@0:     return complain(1, 'lipo create fat failed for:',
michael@0:                     @thinFiles,
michael@0:                     $targetPath);
michael@0:   }
michael@0: 
michael@0:   unlink(@tempThinFiles);
michael@0: 
michael@0:   if (!$gDryRun) {
michael@0:     # lipo seems to think that it's free to set its own file modes that
michael@0:     # ignore the umask, which is bogus when the rest of this script
michael@0:     # respects the umask.
michael@0:     if (!chmod(($isExecutable ? 0777 : 0666) & ~umask(), $targetPath)) {
michael@0:       complain(1, 'makeUniversalFile: chmod: '.$!.' for',
michael@0:                $targetPath);
michael@0:       unlink($targetPath);
michael@0:       return 0;
michael@0:     }
michael@0:   }
michael@0: 
michael@0:   return 1;
michael@0: }
michael@0: 
michael@0: # makeUniversalInternal($isToplevel, $filePPC, $fileX86, $fileTargetPath)
michael@0: #
michael@0: # Given FileAttrCache objects $filePPC and $fileX86, compares filetypes
michael@0: # and performs the appropriate action to produce a universal file at
michael@0: # path string $fileTargetPath.  $isToplevel should be true if this is
michael@0: # the recursive base and false otherwise; this controls cleanup behavior
michael@0: # (cleanup is only performed at the base, because cleanup itself is
michael@0: # recursive).
michael@0: #
michael@0: # This handles regular files by determining whether they are Mach-O files
michael@0: # and calling makeUniversalFile if so and copyIfIdentical otherwise.  Symbolic
michael@0: # links are handled directly in this function by ensuring that the source link
michael@0: # targets are identical and creating a new link with the same target
michael@0: # at $fileTargetPath.  Directories are handled by calling
michael@0: # makeUniversalDirectory.
michael@0: #
michael@0: # One of $filePPC and $fileX86 is permitted to be undef.  In that case,
michael@0: # the defined source file is copied directly to the target if a regular
michael@0: # file, and symlinked appropriately if a symbolic link.  This facilitates
michael@0: # use of $gOnlyOne = 'copy', although no $gOnlyOne checks are made in this
michael@0: # function, they are all handled in makeUniversalDirectory.
michael@0: #
michael@0: # Returns true on success.  Returns false on failure, including failures
michael@0: # in other functions called.
michael@0: sub makeUniversalInternal($$$$) {
michael@0:   my ($filePPC, $fileTargetPath, $fileX86, $isToplevel);
michael@0:   ($isToplevel, $filePPC, $fileX86, $fileTargetPath) = @_;
michael@0: 
michael@0:   my ($typePPC, $typeX86);
michael@0:   if (defined($filePPC) && !defined($typePPC = $filePPC->lstatType())) {
michael@0:     return complain(1, 'makeUniversal: lstat ppc: '.$!.' for:',
michael@0:                     $filePPC->path());
michael@0:   }
michael@0:   if (defined($fileX86) && !defined($typeX86 = $fileX86->lstatType())) {
michael@0:     return complain(1, 'makeUniversal: lstat x86: '.$!.' for:',
michael@0:                     $fileX86->path());
michael@0:   }
michael@0: 
michael@0:   if (defined($filePPC) && defined($fileX86) && $typePPC != $typeX86) {
michael@0:     return complain(1, 'makeUniversal: incompatible types:',
michael@0:                     $filePPC->path(),
michael@0:                     $fileX86->path());
michael@0:   }
michael@0: 
michael@0:   # $aSourceFile will contain a FileAttrCache object that will return
michael@0:   # the correct type data.  It's used because it's possible for one of
michael@0:   # the two source files to be undefined (indicating a straight copy).
michael@0:   my ($aSourceFile);
michael@0:   if (defined($filePPC)) { 
michael@0:     $aSourceFile = $filePPC;
michael@0:   }
michael@0:   else {
michael@0:     $aSourceFile = $fileX86;
michael@0:   }
michael@0: 
michael@0:   if ($aSourceFile->lIsDir()) {
michael@0:     if ($gVerbosity >= 3 || $gDryRun) {
michael@0:       print('mkdir '.(argumentEscape($fileTargetPath))[0]."\n");
michael@0:     }
michael@0:     if (!$gDryRun && !mkdir($fileTargetPath)) {
michael@0:       return complain(1, 'makeUniversal: mkdir: '.$!.' for:',
michael@0:                       $fileTargetPath);
michael@0:     }
michael@0: 
michael@0:     my ($rv);
michael@0: 
michael@0:     if (!($rv = makeUniversalDirectory($filePPC, $fileX86, $fileTargetPath))) {
michael@0:       # makeUniversalDirectory printed an error.
michael@0:       if ($isToplevel) {
michael@0:         command($gConfig{'cmd_rm'},'-rf','--',$fileTargetPath);
michael@0:       }
michael@0:     }
michael@0:     else {
michael@0:       # Touch the directory when leaving it.  If unify is being run on an
michael@0:       # .app bundle, the .app might show up without an icon because the
michael@0:       # system might have found the .app before it was completely built.
michael@0:       # Touching it dirties it in LaunchServices' mind.
michael@0:       if ($gVerbosity >= 3) {
michael@0:         print('touch '.(argumentEscape($fileTargetPath))[0]."\n");
michael@0:       }
michael@0:       utime(undef, undef, $fileTargetPath);
michael@0:     }
michael@0: 
michael@0:     return $rv;
michael@0:   }
michael@0:   elsif ($aSourceFile->lIsSymLink()) {
michael@0:     my ($linkPPC, $linkX86);
michael@0:     if (defined($filePPC) && !defined($linkPPC=readlink($filePPC->path()))) {
michael@0:       return complain(1, 'makeUniversal: readlink ppc: '.$!.' for:',
michael@0:                       $filePPC->path());
michael@0:     }
michael@0:     if (defined($fileX86) && !defined($linkX86=readlink($fileX86->path()))) {
michael@0:       return complain(1, 'makeUniversal: readlink x86: '.$!.' for:',
michael@0:                       $fileX86->path());
michael@0:     }
michael@0:     if (defined($filePPC) && defined($fileX86) && $linkPPC ne $linkX86) {
michael@0:       return complain(1, 'makeUniversal: symbolic links differ:',
michael@0:                       $filePPC->path(),
michael@0:                       $fileX86->path());
michael@0:     }
michael@0: 
michael@0:     # $aLink here serves the same purpose as $aSourceFile in the enclosing
michael@0:     # block: it refers to the target of the symbolic link, whether there
michael@0:     # is one valid source or two.
michael@0:     my ($aLink);
michael@0:     if (defined($linkPPC)) {
michael@0:       $aLink = $linkPPC;
michael@0:     }
michael@0:     else {
michael@0:       $aLink = $linkX86;
michael@0:     }
michael@0: 
michael@0:     if ($gVerbosity >= 3 || $gDryRun) {
michael@0:       print('ln -s '.
michael@0:             join(' ',argumentEscape($aLink, $fileTargetPath))."\n");
michael@0:     }
michael@0:     if (!$gDryRun && !symlink($aLink, $fileTargetPath)) {
michael@0:       return complain(1, 'makeUniversal: symlink: '.$!.' for:',
michael@0:                       $aLink,
michael@0:                       $fileTargetPath);
michael@0:     }
michael@0: 
michael@0:     return 1;
michael@0:   }
michael@0:   elsif($aSourceFile->lIsRegularFile()) {
michael@0:     my ($machPPC, $machX86, $fileName);
michael@0:     if (!defined($filePPC) || !defined($fileX86)) {
michael@0:       # One of the source files isn't present.  The right thing to do is
michael@0:       # to just copy what does exist straight over, so skip Mach-O checks.
michael@0:       $machPPC = 0;
michael@0:       $machX86 = 0;
michael@0:       if (defined($filePPC)) {
michael@0:         $fileName = $filePPC;
michael@0:       } elsif (defined($fileX86)) {
michael@0:         $fileName = $fileX86;
michael@0:       } else {
michael@0:         complain(1, "The file must exist in at least one directory");
michael@0:         exit(1);
michael@0:       }
michael@0:     }
michael@0:     else {
michael@0:       # both files exist, pick the name of one.
michael@0:       $fileName = $fileX86;
michael@0:       if (!defined($machPPC=$filePPC->isMachO())) {
michael@0:         return complain(1, 'makeUniversal: isFileMachO ppc failed for:',
michael@0:                         $filePPC->path());
michael@0:       }
michael@0:       if (!defined($machX86=$fileX86->isMachO())) {
michael@0:         return complain(1, 'makeUniversal: isFileMachO x86 failed for:',
michael@0:                         $fileX86->path());
michael@0:       }
michael@0:     }
michael@0: 
michael@0:     if ($machPPC != $machX86) {
michael@0:       return complain(1, 'makeUniversal: variant Mach-O attributes:',
michael@0:                       $filePPC->path(),
michael@0:                   $fileX86->path());
michael@0:     }
michael@0: 
michael@0:     if ($machPPC) {
michael@0:       # makeUniversalFile will print an error if it fails.
michael@0:       return makeUniversalFile($filePPC, $fileX86, $fileTargetPath);
michael@0:     }
michael@0: 
michael@0:     if (grep { $fileName->path() =~ m/$_/; } @gSortMatches) {
michael@0:       # Regular files, but should be compared with sorting first.
michael@0:       # copyIfIdenticalWhenSorted will print an error if it fails.
michael@0:       return copyIfIdenticalWhenSorted($filePPC, $fileX86, $fileTargetPath);
michael@0:     }
michael@0: 
michael@0:     # Regular file.  copyIfIdentical will print an error if it fails.
michael@0:     return copyIfIdentical($filePPC, $fileX86, $fileTargetPath);
michael@0:   }
michael@0: 
michael@0:   # Special file, don't know how to handle.
michael@0:   return complain(1, 'makeUniversal: cannot handle special file:',
michael@0:                   $filePPC->path(),
michael@0:                   $fileX86->path());
michael@0: }
michael@0: 
michael@0: # usage()
michael@0: #
michael@0: # Give the user a hand.
michael@0: sub usage() {
michael@0:   print STDERR (
michael@0: "usage: unify <ppc-path> <x86-path> <universal-path>\n".
michael@0: "            [--dry-run]           (print what would be done)\n".
michael@0: "            [--only-one <action>] (skip, copy, fail; default=copy)\n".
michael@0: "            [--verbosity <level>] (0, 1, 2, 3; default=2)\n");
michael@0:   return;
michael@0: }
michael@0: 
michael@0: # readZipCRCs($zipFile)
michael@0: #
michael@0: # $zipFile is the pathname to a zip file whose directory will be read.
michael@0: # A reference to a hash is returned, with the member pathnames from the
michael@0: # zip file as keys, and reasonably unique identifiers as values.  The
michael@0: # format of the values is not specified exactly, but does include the
michael@0: # member CRCs and sizes and differentiates between files and directories.
michael@0: # It specifically does not distinguish between modification times.  On
michael@0: # failure, prints a message and returns undef.
michael@0: sub readZipCRCs($) {
michael@0:   my ($zipFile);
michael@0:   ($zipFile) = @_;
michael@0: 
michael@0:   my ($ze, $zip);
michael@0:   $zip = Archive::Zip->new();
michael@0: 
michael@0:   if (($ze = $zip->read($zipFile)) != AZ_OK) {
michael@0:     complain(1, 'readZipCRCs: read error '.$ze.' for:',
michael@0:              $zipFile);
michael@0:     return undef;
michael@0:   }
michael@0: 
michael@0:   my ($member, %memberCRCs, @memberList);
michael@0:   %memberCRCs = ();
michael@0:   @memberList = $zip->members();
michael@0: 
michael@0:   foreach $member (@memberList) {
michael@0:     # Take a few of the attributes that identify the file and stuff them into
michael@0:     # the members hash.  Directories will show up with size 0 and crc32 0,
michael@0:     # so isDirectory() is used to distinguish them from empty files.
michael@0:     $memberCRCs{$member->fileName()} = join(',', $member->isDirectory() ? 1 : 0,
michael@0:                                                  $member->uncompressedSize(),
michael@0:                                                  $member->crc32String());
michael@0:   }
michael@0: 
michael@0:   return {%memberCRCs};
michael@0: }
michael@0: 
michael@0: {
michael@0:   # FileAttrCache allows various attributes about a file to be cached
michael@0:   # so that if they are needed again after first use, no system calls
michael@0:   # will be made and the program won't need to hit the disk.
michael@0: 
michael@0:   package FileAttrCache;
michael@0: 
michael@0:   # from /usr/include/mach-o/loader.h
michael@0:   use constant MH_MAGIC    => 0xfeedface;
michael@0:   use constant MH_CIGAM    => 0xcefaedfe;
michael@0:   use constant MH_MAGIC_64 => 0xfeedfacf;
michael@0:   use constant MH_CIGAM_64 => 0xcffaedfe;
michael@0: 
michael@0:   use Fcntl(':DEFAULT', ':mode');
michael@0: 
michael@0:   # FileAttrCache->new($path)
michael@0:   #
michael@0:   # Creates a new FileAttrCache object for the file at path $path and
michael@0:   # returns it.  The cache is not primed at creation time, values are
michael@0:   # fetched lazily as they are needed.
michael@0:   sub new($$) {
michael@0:     my ($class, $path, $proto, $this);
michael@0:     ($proto, $path) = @_;
michael@0:     if (!($class = ref($proto))) {
michael@0:       $class = $proto;
michael@0:     }
michael@0:     $this = {
michael@0:       'path'        => $path,
michael@0:       'lstat'       => undef,
michael@0:       'lstatErrno'  => 0,
michael@0:       'lstatInit'   => 0,
michael@0:       'magic'       => undef,
michael@0:       'magic2'       => undef,
michael@0:       'magicErrno'  => 0,
michael@0:       'magicErrMsg' => undef,
michael@0:       'magicInit'   => 0,
michael@0:       'stat'        => undef,
michael@0:       'statErrno'   => 0,
michael@0:       'statInit'    => 0,
michael@0:     };
michael@0:     bless($this, $class);
michael@0:     return($this);
michael@0:   }
michael@0: 
michael@0:   # $FileAttrCache->isFat()
michael@0:   #
michael@0:   # Returns true if the file is a fat Mach-O file, false if it's not, and
michael@0:   # undef if an error occurs.  See /usr/include/mach-o/fat.h.
michael@0:   sub isFat($) {
michael@0:     my ($magic, $magic2, $this);
michael@0:     ($this) = @_;
michael@0: 
michael@0:     # magic() caches, there's no separate cache because isFat() doesn't hit
michael@0:     # the disk other than by calling magic().
michael@0: 
michael@0:     if (!defined($magic = $this->magic())) {
michael@0:       return undef;
michael@0:     }
michael@0:     $magic2 = $this->magic2();
michael@0: 
michael@0:     # We have to sanity check the second four bytes, because Java class
michael@0:     # files use the same magic number as Mach-O fat binaries.
michael@0:     # This logic is adapted from file(1), which says that Mach-O uses
michael@0:     # these bytes to count the number of architectures within, while
michael@0:     # Java uses it for a version number. Conveniently, there are only
michael@0:     # 18 labelled Mach-O architectures, and Java's first released
michael@0:     # class format used the version 43.0.
michael@0:     if ($magic == 0xcafebabe && $magic2 < 20) {
michael@0:       return 1;
michael@0:     }
michael@0: 
michael@0:     return 0;
michael@0:   }
michael@0: 
michael@0:   # $FileAttrCache->isMachO()
michael@0:   #
michael@0:   # Returns true if the file is a Mach-O image (including a fat file), false
michael@0:   # if it's not, and undef if an error occurs.  See
michael@0:   # /usr/include/mach-o/loader.h and /usr/include/mach-o/fat.h.
michael@0:   sub isMachO($) {
michael@0:     my ($magic, $this);
michael@0:     ($this) = @_;
michael@0: 
michael@0:     # magic() caches, there's no separate cache because isMachO() doesn't hit
michael@0:     # the disk other than by calling magic().
michael@0: 
michael@0:     if (!defined($magic = $this->magic())) {
michael@0:       return undef;
michael@0:     }
michael@0: 
michael@0:     # Accept Mach-O fat files or Mach-O thin files of either endianness.
michael@0:     if ($magic == MH_MAGIC ||
michael@0:         $magic == MH_CIGAM ||
michael@0:         $magic == MH_MAGIC_64 ||
michael@0:         $magic == MH_CIGAM_64 ||
michael@0:         $this->isFat()) {
michael@0:       return 1;
michael@0:     }
michael@0: 
michael@0:     return 0;
michael@0:   }
michael@0: 
michael@0:   # $FileAttrCache->isZip()
michael@0:   #
michael@0:   # Returns true if the file is a zip file, false if it's not, and undef if
michael@0:   # an error occurs.  See http://www.pkware.com/business_and_developers/developer/popups/appnote.txt .
michael@0:   sub isZip($) {
michael@0:     my ($magic, $this);
michael@0:     ($this) = @_;
michael@0: 
michael@0:     # magic() caches, there's no separate cache because isFat() doesn't hit
michael@0:     # the disk other than by calling magic().
michael@0: 
michael@0:     if (!defined($magic = $this->magic())) {
michael@0:       return undef;
michael@0:     }
michael@0: 
michael@0:     if ($magic == 0x504b0304) {
michael@0:       return 1;
michael@0:     }
michael@0: 
michael@0:     return 0;
michael@0:   }
michael@0: 
michael@0:   # $FileAttrCache->lIsExecutable()
michael@0:   #
michael@0:   # Wraps $FileAttrCache->lstat(), returning true if the file is has any,
michael@0:   # execute bit set, false if none are set, or undef if an error occurs.
michael@0:   # On error, $! is set to lstat's errno.
michael@0:   sub lIsExecutable($) {
michael@0:     my ($mode, $this);
michael@0:     ($this) = @_;
michael@0: 
michael@0:     if (!defined($mode = $this->lstatMode())) {
michael@0:       return undef;
michael@0:     }
michael@0: 
michael@0:     return $mode & (S_IXUSR | S_IXGRP | S_IXOTH);
michael@0:   }
michael@0: 
michael@0:   # $FileAttrCache->lIsDir()
michael@0:   #
michael@0:   # Wraps $FileAttrCache->lstat(), returning true if the file is a directory,
michael@0:   # false if it isn't, or undef if an error occurs.  Because lstat is used,
michael@0:   # this will return false even if the file is a symlink pointing to a
michael@0:   # directory.  On error, $! is set to lstat's errno.
michael@0:   sub lIsDir($) {
michael@0:     my ($type, $this);
michael@0:     ($this) = @_;
michael@0: 
michael@0:     if (!defined($type = $this->lstatType())) {
michael@0:       return undef;
michael@0:     }
michael@0: 
michael@0:     return S_ISDIR($type);
michael@0:   }
michael@0: 
michael@0:   # $FileAttrCache->lIsRegularFile()
michael@0:   #
michael@0:   # Wraps $FileAttrCache->lstat(), returning true if the file is a regular,
michael@0:   # file, false if it isn't, or undef if an error occurs.  Because lstat is
michael@0:   # used, this will return false even if the file is a symlink pointing to a
michael@0:   # regular file.  On error, $! is set to lstat's errno.
michael@0:   sub lIsRegularFile($) {
michael@0:     my ($type, $this);
michael@0:     ($this) = @_;
michael@0: 
michael@0:     if (!defined($type = $this->lstatType())) {
michael@0:       return undef;
michael@0:     }
michael@0: 
michael@0:     return S_ISREG($type);
michael@0:   }
michael@0: 
michael@0:   # $FileAttrCache->lIsSymLink()
michael@0:   #
michael@0:   # Wraps $FileAttrCache->lstat(), returning true if the file is a symbolic,
michael@0:   # link, false if it isn't, or undef if an error occurs.  On error, $! is
michael@0:   # set to lstat's errno.
michael@0:   sub lIsSymLink($) {
michael@0:     my ($type, $this);
michael@0:     ($this) = @_;
michael@0:    
michael@0:     if (!defined($type = $this->lstatType())) {
michael@0:       return undef;
michael@0:     }
michael@0: 
michael@0:     return S_ISLNK($type);
michael@0:   }
michael@0: 
michael@0:   # $FileAttrCache->lstat()
michael@0:   #
michael@0:   # Wraps the lstat system call, providing a cache to speed up multiple
michael@0:   # lstat calls for the same file.  See lstat(2) and lstat in perlfunc(1).
michael@0:   sub lstat($) {
michael@0:     my (@stat, $this);
michael@0:     ($this) = @_;
michael@0: 
michael@0:     # Use the cached lstat result.
michael@0:     if ($$this{'lstatInit'}) {
michael@0:       if (defined($$this{'lstatErrno'})) {
michael@0:         $! = $$this{'lstatErrno'};
michael@0:       }
michael@0:       return @{$$this{'lstat'}};
michael@0:     }
michael@0:     $$this{'lstatInit'} = 1;
michael@0: 
michael@0:     if (!(@stat = CORE::lstat($$this{'path'}))) {
michael@0:       $$this{'lstatErrno'} = $!;
michael@0:     }
michael@0: 
michael@0:     $$this{'lstat'} = [@stat];
michael@0:     return @stat;
michael@0:   }
michael@0: 
michael@0:   # $FileAttrCache->lstatMode()
michael@0:   #
michael@0:   # Wraps $FileAttrCache->lstat(), returning the mode bits from the st_mode
michael@0:   # field, or undef if an error occurs.  On error, $! is set to lstat's
michael@0:   # errno.
michael@0:   sub lstatMode($) {
michael@0:     my (@stat, $this);
michael@0:     ($this) = @_;
michael@0: 
michael@0:     if (!(@stat = $this->lstat())) {
michael@0:       return undef;
michael@0:     }
michael@0: 
michael@0:     return S_IMODE($stat[2]);
michael@0:   }
michael@0: 
michael@0:   # $FileAttrCache->lstatType()
michael@0:   #
michael@0:   # Wraps $FileAttrCache->lstat(), returning the type bits from the st_mode
michael@0:   # field, or undef if an error occurs.  On error, $! is set to lstat's
michael@0:   # errno.
michael@0:   sub lstatType($) {
michael@0:     my (@stat, $this);
michael@0:     ($this) = @_;
michael@0: 
michael@0:     if (!(@stat = $this->lstat())) {
michael@0:       return undef;
michael@0:     }
michael@0: 
michael@0:     return S_IFMT($stat[2]);
michael@0:   }
michael@0: 
michael@0:   # $FileAttrCache->magic()
michael@0:   #
michael@0:   # Returns the "magic number" for the file by reading its first four bytes
michael@0:   # as a big-endian unsigned 32-bit integer and returning the result.  If an
michael@0:   # error occurs, returns undef and prints diagnostic messages to stderr.  If
michael@0:   # the file is shorter than 32 bits, returns -1.  A cache is provided to
michael@0:   # speed multiple magic calls for the same file.
michael@0:   sub magic($) {
michael@0:     my ($this);
michael@0:     ($this) = @_;
michael@0: 
michael@0:     # Use the cached magic result.
michael@0:     if ($$this{'magicInit'}) {
michael@0:       if (defined($$this{'magicErrno'})) {
michael@0:         if (defined($$this{'magicErrMsg'})) {
michael@0:           complain(1, 'FileAttrCache::magic: '.$$this{'magicErrMsg'}.' for:',
michael@0:                    $$this{'path'});
michael@0:         }
michael@0:         $! = $$this{'magicErrno'};
michael@0:       }
michael@0:       return $$this{'magic'};
michael@0:     }
michael@0: 
michael@0:     $$this{'magicInit'} = 1;
michael@0: 
michael@0:     my ($fh);
michael@0:     if (!sysopen($fh, $$this{'path'}, O_RDONLY)) {
michael@0:       $$this{'magicErrno'} = $!;
michael@0:       $$this{'magicErrMsg'} = 'open "'.$$this{'path'}.'": '.$!;
michael@0:       complain(1, 'FileAttrCache::magic: '.$$this{'magicErrMsg'}.' for:',
michael@0:                $$this{'path'});
michael@0:       return undef;
michael@0:     }
michael@0: 
michael@0:     $! = 0;
michael@0:     my ($bytes, $magic, $bytes2, $magic2);
michael@0:     if (!defined($bytes = sysread($fh, $magic, 4))) {
michael@0:       $$this{'magicErrno'} = $!;
michael@0:       $$this{'magicErrMsg'} = 'read "'.$$this{'path'}.'": '.$!;
michael@0:       complain(1, 'FileAttrCache::magic: '.$$this{'magicErrMsg'}.' for:',
michael@0:                $$this{'path'});
michael@0:       close($fh);
michael@0:       return undef;
michael@0:     }
michael@0:     else {
michael@0:       $bytes2 = sysread($fh, $magic2, 4);
michael@0:     }
michael@0: 
michael@0:     close($fh);
michael@0: 
michael@0:     if ($bytes != 4) {
michael@0:       # The file is too short, didn't read a magic number.  This isn't really
michael@0:       # an error.  Return an unlikely value.
michael@0:       $$this{'magic'} = -1;
michael@0:       $$this{'magic2'} = -1;
michael@0:       return -1;
michael@0:     }
michael@0:     if ($bytes2 != 4) {
michael@0:       # File is too short to read a second 4 bytes.
michael@0:       $magic2 = -1;
michael@0:     }
michael@0: 
michael@0:     $$this{'magic'} = unpack('N', $magic);
michael@0:     $$this{'magic2'} = unpack('N', $magic2);
michael@0:     return $$this{'magic'};
michael@0:   }
michael@0: 
michael@0:   # $FileAttrCache->magic2()
michael@0:   #
michael@0:   # Returns the second four bytes of the file as a 32-bit little endian number.
michael@0:   # See magic(), above for more info.
michael@0:   sub magic2($) {
michael@0:     my ($this);
michael@0:     ($this) = @_;
michael@0: 
michael@0:     # we do the actual work (and cache it) in magic().
michael@0:     if (!$$this{'magicInit'}) {
michael@0:       my $magic = $$this->magic();
michael@0:     }
michael@0: 
michael@0:     return $$this{'magic2'};
michael@0:   }
michael@0: 
michael@0:   # $FileAttrCache->path()
michael@0:   #
michael@0:   # Returns the file's pathname.
michael@0:   sub path($) {
michael@0:     my ($this);
michael@0:     ($this) = @_;
michael@0:     return $$this{'path'};
michael@0:   }
michael@0: 
michael@0:   # $FileAttrCache->stat()
michael@0:   #
michael@0:   # Wraps the stat system call, providing a cache to speed up multiple
michael@0:   # stat calls for the same file.  If lstat() has already been called and
michael@0:   # the file is not a symbolic link, the cached lstat() result will be used.
michael@0:   # See stat(2) and lstat in perlfunc(1).
michael@0:   sub stat($) {
michael@0:     my (@stat, $this);
michael@0:     ($this) = @_;
michael@0: 
michael@0:     # Use the cached stat result.
michael@0:     if ($$this{'statInit'}) {
michael@0:       if (defined($$this{'statErrno'})) {
michael@0:         $! = $$this{'statErrno'};
michael@0:       }
michael@0:       return @{$$this{'stat'}};
michael@0:     }
michael@0: 
michael@0:     $$this{'statInit'} = 1;
michael@0: 
michael@0:     # If lstat has already been called, and the file isn't a symbolic link,
michael@0:     # use the cached lstat result.
michael@0:     if ($$this{'lstatInit'} && !$$this{'lstatErrno'} &&
michael@0:         !S_ISLNK(${$$this{'lstat'}}[2])) {
michael@0:       $$this{'stat'} = $$this{'lstat'};
michael@0:       return @{$$this{'stat'}};
michael@0:     }
michael@0: 
michael@0:     if (!(@stat = CORE::stat($$this{'path'}))) {
michael@0:       $$this{'statErrno'} = $!;
michael@0:     }
michael@0: 
michael@0:     $$this{'stat'} = [@stat];
michael@0:     return @stat;
michael@0:   }
michael@0: 
michael@0:   # $FileAttrCache->statSize()
michael@0:   #
michael@0:   # Wraps $FileAttrCache->stat(), returning the st_size field, or undef
michael@0:   # undef if an error occurs.  On error, $! is set to stat's errno.
michael@0:   sub statSize($) {
michael@0:     my (@stat, $this);
michael@0:     ($this) = @_;
michael@0: 
michael@0:     if (!(@stat = $this->lstat())) {
michael@0:       return undef;
michael@0:     }
michael@0: 
michael@0:     return $stat[7];
michael@0:   }
michael@0: }