1.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
1.2 +++ b/build/macosx/universal/unify Wed Dec 31 06:09:35 2014 +0100
1.3 @@ -0,0 +1,1525 @@
1.4 +#!/usr/bin/perl
1.5 +# This Source Code Form is subject to the terms of the Mozilla Public
1.6 +# License, v. 2.0. If a copy of the MPL was not distributed with this
1.7 +# file, You can obtain one at http://mozilla.org/MPL/2.0/.
1.8 +
1.9 +use strict;
1.10 +use warnings;
1.11 +
1.12 +=pod
1.13 +
1.14 +=head1 NAME
1.15 +
1.16 +B<unify> - Mac OS X universal binary packager
1.17 +
1.18 +=head1 SYNOPSIS
1.19 +
1.20 +B<unify>
1.21 +I<ppc-path>
1.22 +I<x86-path>
1.23 +I<universal-path>
1.24 +[B<--dry-run>]
1.25 +[B<--only-one> I<action>]
1.26 +[B<--verbosity> I<level>]
1.27 +[B<--unify-with-sort> I<regex>]
1.28 +
1.29 +=head1 DESCRIPTION
1.30 +
1.31 +I<unify> merges any two architecture-specific files or directory trees
1.32 +into a single file or tree suitable for use on either architecture as a
1.33 +"fat" or "universal binary."
1.34 +
1.35 +Architecture-specific Mach-O files will be merged into fat Mach-O files
1.36 +using L<lipo(1)>. Non-Mach-O files in the architecture-specific trees
1.37 +are compared to ensure that they are equivalent before copying. Symbolic
1.38 +links are permitted in the architecture-specific trees and will cause
1.39 +identical links to be created in the merged tree, provided that the source
1.40 +links have identical targets. Directories are processed recursively.
1.41 +
1.42 +If the architecture-specific source trees contain zip archives (including
1.43 +jar files) that are not identical according to a byte-for-byte check, they
1.44 +are still assumed to be equivalent if both archives contain exactly the
1.45 +same members with identical checksums and sizes.
1.46 +
1.47 +Behavior when one architecture-specific tree contains files that the other
1.48 +does not is controlled by the B<--only-one> option.
1.49 +
1.50 +If Mach-O files cannot be merged using L<lipo(1)>, zip archives are not
1.51 +equivalent, regular files are not identical, or any other error occurs,
1.52 +B<unify> will fail with an exit status of 1. Diagnostic messages are
1.53 +typically printed to stderr; this behavior can be controlled with the
1.54 +B<--verbosity> option.
1.55 +
1.56 +=head1 OPTIONS
1.57 +
1.58 +=over 5
1.59 +
1.60 +=item I<ppc-path>
1.61 +
1.62 +=item I<x86-path>
1.63 +
1.64 +The paths to directory trees containing PowerPC and x86 builds,
1.65 +respectively. I<ppc-path> and I<x86-path> are permitted to contain files
1.66 +that are already "fat," and only the appropriate architecture's images will
1.67 +be used.
1.68 +
1.69 +I<ppc-path> and I<x86-path> are also permitted to both be files, in which
1.70 +case B<unify> operates solely on those files, and produces an appropriate
1.71 +merged file at I<target-path>.
1.72 +
1.73 +=item I<target-path>
1.74 +
1.75 +The path to the merged file or directory tree. This path will be created,
1.76 +and it must not exist prior to running B<unify>.
1.77 +
1.78 +=item B<--dry-run>
1.79 +
1.80 +When specified, the commands that would be executed are printed, without
1.81 +actually executing them. Note that B<--dry-run> and the equivalent
1.82 +B<--verbosity> level during "wet" runs may print equivalent commands when
1.83 +no commands are in fact executed: certain operations are handled internally
1.84 +within B<unify>, and an approximation of a command that performs a similar
1.85 +task is printed.
1.86 +
1.87 +=item B<--only-one> I<action>
1.88 +
1.89 +Controls handling of files that are only present in one of the two source
1.90 +trees. I<action> may be:
1.91 + skip - These files are skipped.
1.92 + copy - These files are copied from the tree in which they exist.
1.93 + fail - When this condition occurs, it is treated as an error.
1.94 +
1.95 +The default I<action> is copy.
1.96 +
1.97 +=item B<--verbosity> I<level>
1.98 +
1.99 +Adjusts the level of loudness of B<unify>. The possible values for
1.100 +I<level> are:
1.101 + 0 - B<unify> never prints anything.
1.102 + (Other programs that B<unify> calls may still print messages.)
1.103 + 1 - Fatal error messages are printed to stderr.
1.104 + 2 - Nonfatal warnings are printed to stderr.
1.105 + 3 - Commands are printed to stdout as they are executed.
1.106 +
1.107 +The default I<level> is 2.
1.108 +
1.109 +=item B<--unify-with-sort> I<regex>
1.110 +
1.111 +Allows merging files matching I<regex> that differ only by the ordering
1.112 +of the lines contained within them. The unified file will have its contents
1.113 +sorted. This option may be given multiple times to specify multiple
1.114 +regexes for matching files.
1.115 +
1.116 +=back
1.117 +
1.118 +=head1 EXAMPLES
1.119 +
1.120 +=over 5
1.121 +
1.122 +=item Create a universal .app bundle from two architecture-specific .app
1.123 +bundles:
1.124 +
1.125 +unify --only-one copy ppc/dist/firefox/Firefox.app
1.126 + x86/dist/firefox/Firefox.app universal/Firefox.app
1.127 + --verbosity 3
1.128 +
1.129 +=item Merge two identical architecture-specific trees:
1.130 +
1.131 +unify --only-one fail /usr/local /nfs/x86/usr/local
1.132 + /tmp/usrlocal.fat
1.133 +
1.134 +=back
1.135 +
1.136 +=head1 REQUIREMENTS
1.137 +
1.138 +The only esoteric requirement of B<unify> is that the L<lipo(1)> command
1.139 +be available. It is present on Mac OS X systems at least as early as
1.140 +10.3.9, and probably earlier. Mac OS X 10.4 ("Tiger") or later are
1.141 +recommended.
1.142 +
1.143 +=head1 LICENSE
1.144 +
1.145 +MPL 2.
1.146 +
1.147 +=head1 AUTHOR
1.148 +
1.149 +The software was initially written by Mark Mentovai; copyright 2006
1.150 +Google Inc.
1.151 +
1.152 +=head1 SEE ALSO
1.153 +
1.154 +L<cmp(1)>, L<ditto(1)>, L<lipo(1)>
1.155 +
1.156 +=cut
1.157 +
1.158 +use Archive::Zip(':ERROR_CODES');
1.159 +use Errno;
1.160 +use Fcntl;
1.161 +use File::Compare;
1.162 +use File::Copy;
1.163 +use Getopt::Long;
1.164 +
1.165 +my (%gConfig, $gDryRun, $gOnlyOne, $gVerbosity, @gSortMatches);
1.166 +
1.167 +sub argumentEscape(@);
1.168 +sub command(@);
1.169 +sub compareZipArchives($$);
1.170 +sub complain($$@);
1.171 +sub copyIfIdentical($$$);
1.172 +sub slurp($);
1.173 +sub get_sorted($);
1.174 +sub compare_sorted($$);
1.175 +sub copyIfIdenticalWhenSorted($$$);
1.176 +sub createUniqueFile($$);
1.177 +sub makeUniversal($$$);
1.178 +sub makeUniversalDirectory($$$);
1.179 +sub makeUniversalInternal($$$$);
1.180 +sub makeUniversalFile($$$);
1.181 +sub usage();
1.182 +sub readZipCRCs($);
1.183 +
1.184 +{
1.185 + package FileAttrCache;
1.186 +
1.187 + sub new($$);
1.188 +
1.189 + sub isFat($);
1.190 + sub isMachO($);
1.191 + sub isZip($);
1.192 + sub lIsDir($);
1.193 + sub lIsExecutable($);
1.194 + sub lIsRegularFile($);
1.195 + sub lIsSymLink($);
1.196 + sub lstat($);
1.197 + sub lstatMode($);
1.198 + sub lstatType($);
1.199 + sub magic($);
1.200 + sub magic2($);
1.201 + sub path($);
1.202 + sub stat($);
1.203 + sub statSize($);
1.204 +}
1.205 +
1.206 +%gConfig = (
1.207 + 'cmd_lipo' => 'lipo',
1.208 + 'cmd_rm' => 'rm',
1.209 +);
1.210 +
1.211 +$gDryRun = 0;
1.212 +$gOnlyOne = 'copy';
1.213 +$gVerbosity = 2;
1.214 +@gSortMatches = ();
1.215 +
1.216 +Getopt::Long::Configure('pass_through');
1.217 +GetOptions('dry-run' => \$gDryRun,
1.218 + 'only-one=s' => \$gOnlyOne,
1.219 + 'verbosity=i' => \$gVerbosity,
1.220 + 'unify-with-sort=s' => \@gSortMatches,
1.221 + 'config=s' => \%gConfig); # "hidden" option not in usage()
1.222 +
1.223 +if (scalar(@ARGV) != 3 || $gVerbosity < 0 || $gVerbosity > 3 ||
1.224 + ($gOnlyOne ne 'skip' && $gOnlyOne ne 'copy' && $gOnlyOne ne 'fail')) {
1.225 + usage();
1.226 + exit(1);
1.227 +}
1.228 +
1.229 +if (!makeUniversal($ARGV[0],$ARGV[1],$ARGV[2])) {
1.230 + # makeUniversal or something it called will have printed an error.
1.231 + exit(1);
1.232 +}
1.233 +
1.234 +exit(0);
1.235 +
1.236 +# argumentEscape(@arguments)
1.237 +#
1.238 +# Takes a list of @arguments and makes them shell-safe.
1.239 +sub argumentEscape(@) {
1.240 + my (@arguments);
1.241 + @arguments = @_;
1.242 +
1.243 + my ($argument, @argumentsOut);
1.244 + foreach $argument (@arguments) {
1.245 + $argument =~ s%([^A-Za-z0-9_\-/.=+,])%\\$1%g;
1.246 + push(@argumentsOut, $argument);
1.247 + }
1.248 +
1.249 + return @argumentsOut;
1.250 +}
1.251 +
1.252 +# command(@arguments)
1.253 +#
1.254 +# Runs the specified command by calling system(@arguments). If $gDryRun
1.255 +# is true, the command is printed but not executed, and 0 is returned.
1.256 +# if $gVerbosity is greater than 1, the command is printed before being
1.257 +# executed. When the command is executed, the system() return value will
1.258 +# be returned. stdout and stderr are left connected for command output.
1.259 +sub command(@) {
1.260 + my (@arguments);
1.261 + @arguments = @_;
1.262 + if ($gVerbosity >= 3 || $gDryRun) {
1.263 + print(join(' ', argumentEscape(@arguments))."\n");
1.264 + }
1.265 + if ($gDryRun) {
1.266 + return 0;
1.267 + }
1.268 + return system(@arguments);
1.269 +}
1.270 +
1.271 +# compareZipArchives($zip1, $zip2)
1.272 +#
1.273 +# Given two pathnames to zip archives, determines whether or not they are
1.274 +# functionally identical. Returns true if they are, false if they differ in
1.275 +# some substantial way, and undef if an error occurs. If the zip files
1.276 +# differ, diagnostic messages are printed indicating how they differ.
1.277 +#
1.278 +# Zip files will differ if any of the members are different as defined by
1.279 +# readZipCRCs, which consider CRCs, sizes, and file types as stored in the
1.280 +# file header. Timestamps are not considered. Zip files also differ if one
1.281 +# file contains members that the other one does not. $gOnlyOne has no
1.282 +# effect on this behavior.
1.283 +sub compareZipArchives($$) {
1.284 + my ($zip1, $zip2);
1.285 + ($zip1, $zip2) = @_;
1.286 +
1.287 + my ($CRCHash1, $CRCHash2);
1.288 + if (!defined($CRCHash1 = readZipCRCs($zip1))) {
1.289 + # readZipCRCs printed an error.
1.290 + return undef;
1.291 + }
1.292 + if (!defined($CRCHash2 = readZipCRCs($zip2))) {
1.293 + # readZipCRCs printed an error.
1.294 + return undef;
1.295 + }
1.296 +
1.297 + my (@diffCRCs, @onlyInZip1);
1.298 + @diffCRCs = ();
1.299 + @onlyInZip1 = ();
1.300 +
1.301 + my ($memberName);
1.302 + foreach $memberName (keys(%$CRCHash1)) {
1.303 + if (!exists($$CRCHash2{$memberName})) {
1.304 + # The member is present in $zip1 but not $zip2.
1.305 + push(@onlyInZip1, $memberName);
1.306 + }
1.307 + elsif ($$CRCHash1{$memberName} ne $$CRCHash2{$memberName}) {
1.308 + # The member is present in both archives but its CRC or some other
1.309 + # other critical attribute isn't identical.
1.310 + push(@diffCRCs, $memberName);
1.311 + }
1.312 + delete($$CRCHash2{$memberName});
1.313 + }
1.314 +
1.315 + # If any members remain in %CRCHash2, it's because they're not present
1.316 + # in $zip1.
1.317 + my (@onlyInZip2);
1.318 + @onlyInZip2 = keys(%$CRCHash2);
1.319 +
1.320 + if (scalar(@onlyInZip1) + scalar(@onlyInZip2) + scalar(@diffCRCs)) {
1.321 + complain(1, 'compareZipArchives: zip archives differ:',
1.322 + $zip1,
1.323 + $zip2);
1.324 + if (scalar(@onlyInZip1)) {
1.325 + complain(1, 'compareZipArchives: members only in former:',
1.326 + @onlyInZip1);
1.327 + }
1.328 + if (scalar(@onlyInZip2)) {
1.329 + complain(1, 'compareZipArchives: members only in latter:',
1.330 + @onlyInZip2);
1.331 + }
1.332 + if (scalar(@diffCRCs)) {
1.333 + complain(1, 'compareZipArchives: members differ:',
1.334 + @diffCRCs);
1.335 + }
1.336 + return 0;
1.337 + }
1.338 +
1.339 + return 1;
1.340 +}
1.341 +
1.342 +# complain($severity, $message, @list)
1.343 +#
1.344 +# Prints $message to stderr if $gVerbosity allows it for severity level
1.345 +# $severity. @list is a list of words that will be shell-escaped and printed
1.346 +# after $message, one per line, intended to be used, for example, to list
1.347 +# arguments to a call that failed.
1.348 +#
1.349 +# Expected severity levels are 1 for hard errors and 2 for non-fatal warnings.
1.350 +#
1.351 +# Always returns false as a convenience, so callers can return complain's
1.352 +# return value when it is used to signal errors.
1.353 +sub complain($$@) {
1.354 + my ($severity, $message, @list);
1.355 + ($severity, $message, @list) = @_;
1.356 +
1.357 + if ($gVerbosity >= $severity) {
1.358 + print STDERR ($0.': '.$message."\n");
1.359 +
1.360 + my ($item);
1.361 + while ($item = shift(@list)) {
1.362 + print STDERR (' '.(argumentEscape($item))[0].
1.363 + (scalar(@list)?',':'')."\n");
1.364 + }
1.365 + }
1.366 +
1.367 + return 0;
1.368 +}
1.369 +
1.370 +# copyIfIdentical($source1, $source2, $target)
1.371 +#
1.372 +# $source1 and $source2 are FileAttrCache objects that are compared, and if
1.373 +# identical, copied to path string $target. The comparison is initially
1.374 +# done as a byte-for-byte comparison, but if the files differ and appear to
1.375 +# be zip archives, compareZipArchives is called to determine whether
1.376 +# files that are not byte-for-byte identical are equivalent archives.
1.377 +#
1.378 +# Returns true on success, false for files that are not identical or
1.379 +# equivalent archives, and undef if an error occurs.
1.380 +#
1.381 +# One of $source1 and $source2 is permitted to be undef. In this event,
1.382 +# whichever source is defined is copied directly to $target without performing
1.383 +# any comparisons. This enables the $gOnlyOne = 'copy' mode, which is
1.384 +# driven by makeUniversalDirectory and makeUniversalInternal.
1.385 +sub copyIfIdentical($$$) {
1.386 + my ($source1, $source2, $target);
1.387 + ($source1, $source2, $target) = @_;
1.388 +
1.389 + if (!defined($source1)) {
1.390 + # If there's only one source file, make it the first file. Order
1.391 + # isn't important here, and this makes it possible to use
1.392 + # defined($source2) as the switch, and to always copy from $source1.
1.393 + $source1 = $source2;
1.394 + $source2 = undef;
1.395 + }
1.396 +
1.397 + if (defined($source2)) {
1.398 + # Only do the comparisons if there are two source files. If there's
1.399 + # only one source file, skip the comparisons and go straight to the
1.400 + # copy operation.
1.401 + if ($gVerbosity >= 3 || $gDryRun) {
1.402 + print('cmp -s '.
1.403 + join(' ',argumentEscape($source1->path(), $source2->path()))."\n");
1.404 + }
1.405 + my ($comparison);
1.406 + if (!defined($comparison = compare($source1->path(), $source2->path())) ||
1.407 + $comparison == -1) {
1.408 + return complain(1, 'copyIfIdentical: compare: '.$!.' while comparing:',
1.409 + $source1->path(),
1.410 + $source2->path());
1.411 + }
1.412 + elsif ($comparison != 0) {
1.413 + my ($zip1, $zip2);
1.414 + if (defined($zip1 = $source1->isZip()) &&
1.415 + defined($zip2 = $source2->isZip()) &&
1.416 + $zip1 && $zip2) {
1.417 + my ($zipComparison);
1.418 + if (!defined($zipComparison = compareZipArchives($source1->path(),
1.419 + $source2->path)) ||
1.420 + !$zipComparison) {
1.421 + # An error occurred or the zip files aren't sufficiently identical.
1.422 + # compareZipArchives will have printed an error message.
1.423 + return 0;
1.424 + }
1.425 + # The zip files were compared successfully, and they both contain
1.426 + # all of the same members, and all of their members' CRCs are
1.427 + # identical. For the purposes of this script, the zip files can be
1.428 + # treated as identical, so reset $comparison.
1.429 + $comparison = 0;
1.430 + }
1.431 + }
1.432 + if ($comparison != 0) {
1.433 + return complain(1, 'copyIfIdentical: files differ:',
1.434 + $source1->path(),
1.435 + $source2->path());
1.436 + }
1.437 + }
1.438 +
1.439 + if ($gVerbosity >= 3 || $gDryRun) {
1.440 + print('cp '.
1.441 + join(' ',argumentEscape($source1->path(), $target))."\n");
1.442 + }
1.443 +
1.444 + if (!$gDryRun) {
1.445 + my ($isExecutable);
1.446 +
1.447 + # Set the execute bits (as allowed by the umask) on the new file if any
1.448 + # execute bit is set on either old file.
1.449 + $isExecutable = $source1->lIsExecutable() ||
1.450 + (defined($source2) && $source2->lIsExecutable());
1.451 +
1.452 + if (!createUniqueFile($target, $isExecutable ? 0777 : 0666)) {
1.453 + # createUniqueFile printed an error.
1.454 + return 0;
1.455 + }
1.456 +
1.457 + if (!copy($source1->path(), $target)) {
1.458 + complain(1, 'copyIfIdentical: copy: '.$!.' while copying',
1.459 + $source1->path(),
1.460 + $target);
1.461 + unlink($target);
1.462 + return 0;
1.463 + }
1.464 + }
1.465 +
1.466 + return 1;
1.467 +}
1.468 +
1.469 +# slurp($file)
1.470 +#
1.471 +# Read the contents of $file into an array and return it.
1.472 +# Returns undef on error.
1.473 +sub slurp($) {
1.474 + my $file = $_[0];
1.475 + open FILE, $file or return undef;
1.476 + my @lines = <FILE>;
1.477 + close FILE;
1.478 + return @lines;
1.479 +}
1.480 +
1.481 +# get_sorted($file)
1.482 +# Get the sorted lines of a file as a list, normalizing a newline on the last line if necessary.
1.483 +sub get_sorted($) {
1.484 + my ($file) = @_;
1.485 + my @lines = slurp($file);
1.486 + my $lastline = $lines[-1];
1.487 + if (!($lastline =~ /\n/)) {
1.488 + $lines[-1] = $lastline . "\n";
1.489 + }
1.490 + return sort(@lines);
1.491 +}
1.492 +
1.493 +# compare_sorted($file1, $file2)
1.494 +#
1.495 +# Read the contents of both files into arrays, sort the arrays,
1.496 +# and then compare the two arrays for equality.
1.497 +#
1.498 +# Returns 0 if the sorted array contents are equal, or 1 if not.
1.499 +# Returns undef on error.
1.500 +sub compare_sorted($$) {
1.501 + my ($file1, $file2) = @_;
1.502 + my @lines1 = get_sorted($file1);
1.503 + my @lines2 = get_sorted($file2);
1.504 +
1.505 + return undef if !@lines1 || !@lines2;
1.506 + return 1 unless scalar @lines1 == scalar @lines2;
1.507 +
1.508 + for (my $i = 0; $i < scalar @lines1; $i++) {
1.509 + return 1 if $lines1[$i] ne $lines2[$i];
1.510 + }
1.511 + return 0;
1.512 +}
1.513 +
1.514 +# copyIfIdenticalWhenSorted($source1, $source2, $target)
1.515 +#
1.516 +# $source1 and $source2 are FileAttrCache objects that are compared, and if
1.517 +# identical, copied to path string $target. The comparison is done by
1.518 +# sorting the individual lines within the two files and comparing the results.
1.519 +#
1.520 +# Returns true on success, false for files that are not equivalent,
1.521 +# and undef if an error occurs.
1.522 +sub copyIfIdenticalWhenSorted($$$) {
1.523 + my ($source1, $source2, $target);
1.524 + ($source1, $source2, $target) = @_;
1.525 +
1.526 + if ($gVerbosity >= 3 || $gDryRun) {
1.527 + print('cmp -s '.
1.528 + join(' ',argumentEscape($source1->path(), $source2->path()))."\n");
1.529 + }
1.530 + my ($comparison);
1.531 + if (!defined($comparison = compare_sorted($source1->path(),
1.532 + $source2->path())) ||
1.533 + $comparison == -1) {
1.534 + return complain(1, 'copyIfIdenticalWhenSorted: compare: '.$!
1.535 + .' while comparing:',
1.536 + $source1->path(),
1.537 + $source2->path());
1.538 + }
1.539 + if ($comparison != 0) {
1.540 + return complain(1, 'copyIfIdenticalWhenSorted: files differ:',
1.541 + $source1->path(),
1.542 + $source2->path());
1.543 + }
1.544 +
1.545 + if ($gVerbosity >= 3 || $gDryRun) {
1.546 + print('cp '.
1.547 + join(' ',argumentEscape($source1->path(), $target))."\n");
1.548 + }
1.549 +
1.550 + if (!$gDryRun) {
1.551 + my ($isExecutable);
1.552 +
1.553 + # Set the execute bits (as allowed by the umask) on the new file if any
1.554 + # execute bit is set on either old file.
1.555 + $isExecutable = $source1->lIsExecutable() ||
1.556 + (defined($source2) && $source2->lIsExecutable());
1.557 +
1.558 + if (!createUniqueFile($target, $isExecutable ? 0777 : 0666)) {
1.559 + # createUniqueFile printed an error.
1.560 + return 0;
1.561 + }
1.562 +
1.563 + if (!copy($source1->path(), $target)) {
1.564 + complain(1, 'copyIfIdenticalWhenSorted: copy: '.$!
1.565 + .' while copying',
1.566 + $source1->path(),
1.567 + $target);
1.568 + unlink($target);
1.569 + return 0;
1.570 + }
1.571 + }
1.572 +
1.573 + return 1;
1.574 +}
1.575 +
1.576 +# createUniqueFile($path, $mode)
1.577 +#
1.578 +# Creates a new plain empty file at pathname $path, provided it does not
1.579 +# yet exist. $mode is used as the file mode. The actual file's mode will
1.580 +# be modified by the effective umask. Returns false if the file could
1.581 +# not be created, setting $! to the error. An error message is printed
1.582 +# in the event of failure.
1.583 +sub createUniqueFile($$) {
1.584 + my ($path, $mode);
1.585 + ($path, $mode) = @_;
1.586 +
1.587 + my ($fh);
1.588 + if (!sysopen($fh, $path, O_WRONLY | O_CREAT | O_EXCL, $mode)) {
1.589 + return complain(1, 'createUniqueFile: open: '.$!.' for:',
1.590 + $path);
1.591 + }
1.592 + close($fh);
1.593 +
1.594 + return 1;
1.595 +}
1.596 +
1.597 +# makeUniversal($pathPPC, $pathX86, $pathTarget)
1.598 +#
1.599 +# The top-level call. $pathPPC, $pathX86, and $pathTarget are strings
1.600 +# identifying the ppc and x86 files or directories to merge and the location
1.601 +# to merge them to. Returns false on failure and true on success.
1.602 +sub makeUniversal($$$) {
1.603 + my ($pathTarget, $pathPPC, $pathX86);
1.604 + ($pathPPC, $pathX86, $pathTarget) = @_;
1.605 +
1.606 + my ($filePPC, $fileX86);
1.607 + $filePPC = FileAttrCache->new($pathPPC);
1.608 + $fileX86 = FileAttrCache->new($pathX86);
1.609 +
1.610 + return makeUniversalInternal(1, $filePPC, $fileX86, $pathTarget);
1.611 +}
1.612 +
1.613 +# makeUniversalDirectory($dirPPC, $dirX86, $dirTarget)
1.614 +#
1.615 +# This is part of the heart of recursion. $dirPPC and $dirX86 are
1.616 +# FileAttrCache objects designating the source ppc and x86 directories to
1.617 +# merge into a universal directory at $dirTarget, a string. For each file
1.618 +# in $dirPPC and $dirX86, makeUniversalInternal is called.
1.619 +# makeUniversalInternal will call back into makeUniversalDirectory for
1.620 +# directories, thus completing the recursion. If a failure is encountered
1.621 +# in ths function or in makeUniversalInternal or anything that it calls,
1.622 +# false is returned, otherwise, true is returned.
1.623 +#
1.624 +# If there are files present in one source directory but not both, the
1.625 +# value of $gOnlyOne controls the behavior. If $gOnlyOne is 'copy', the
1.626 +# single source file is copied into $pathTarget. If it is 'skip', it is
1.627 +# skipped. If it is 'fail', such files will trigger makeUniversalDirectory
1.628 +# to fail.
1.629 +#
1.630 +# If either source directory is undef, it is treated as having no files.
1.631 +# This facilitates deep recursion when entire directories are only present
1.632 +# in one source when $gOnlyOne = 'copy'.
1.633 +sub makeUniversalDirectory($$$) {
1.634 + my ($dirPPC, $dirX86, $dirTarget);
1.635 + ($dirPPC, $dirX86, $dirTarget) = @_;
1.636 +
1.637 + my ($dh, @filesPPC, @filesX86);
1.638 +
1.639 + @filesPPC = ();
1.640 + if (defined($dirPPC)) {
1.641 + if (!opendir($dh, $dirPPC->path())) {
1.642 + return complain(1, 'makeUniversalDirectory: opendir ppc: '.$!.' for:',
1.643 + $dirPPC->path());
1.644 + }
1.645 + @filesPPC = readdir($dh);
1.646 + closedir($dh);
1.647 + }
1.648 +
1.649 + @filesX86 = ();
1.650 + if (defined($dirX86)) {
1.651 + if (!opendir($dh, $dirX86->path())) {
1.652 + return complain(1, 'makeUniversalDirectory: opendir x86: '.$!.' for:',
1.653 + $dirX86->path());
1.654 + }
1.655 + @filesX86 = readdir($dh);
1.656 + closedir($dh);
1.657 + }
1.658 +
1.659 + my (%common, $file, %onlyPPC, %onlyX86);
1.660 +
1.661 + %onlyPPC = ();
1.662 + foreach $file (@filesPPC) {
1.663 + if ($file eq '.' || $file eq '..') {
1.664 + next;
1.665 + }
1.666 + $onlyPPC{$file}=1;
1.667 + }
1.668 +
1.669 + %common = ();
1.670 + %onlyX86 = ();
1.671 + foreach $file (@filesX86) {
1.672 + if ($file eq '.' || $file eq '..') {
1.673 + next;
1.674 + }
1.675 + if ($onlyPPC{$file}) {
1.676 + delete $onlyPPC{$file};
1.677 + $common{$file}=1;
1.678 + }
1.679 + else {
1.680 + $onlyX86{$file}=1;
1.681 + }
1.682 + }
1.683 +
1.684 + # First, handle files common to both.
1.685 + foreach $file (sort(keys(%common))) {
1.686 + if (!makeUniversalInternal(0,
1.687 + FileAttrCache->new($dirPPC->path().'/'.$file),
1.688 + FileAttrCache->new($dirX86->path().'/'.$file),
1.689 + $dirTarget.'/'.$file)) {
1.690 + # makeUniversalInternal will have printed an error.
1.691 + return 0;
1.692 + }
1.693 + }
1.694 +
1.695 + # Handle files found only in a single directory here. There are three
1.696 + # options, dictated by $gOnlyOne: fail if files are only present in
1.697 + # one directory, skip any files only present in one directory, or copy
1.698 + # these files straight over to the target directory. In any event,
1.699 + # a message will be printed indicating that the file trees don't match
1.700 + # exactly.
1.701 + if (keys(%onlyPPC)) {
1.702 + complain(($gOnlyOne eq 'fail' ? 1 : 2),
1.703 + ($gOnlyOne ne 'fail' ? 'warning: ' : '').
1.704 + 'makeUniversalDirectory: only in ppc '.
1.705 + (argumentEscape($dirPPC->path()))[0].':',
1.706 + argumentEscape(keys(%onlyPPC)));
1.707 + }
1.708 +
1.709 + if (keys(%onlyX86)) {
1.710 + complain(($gOnlyOne eq 'fail' ? 1 : 2),
1.711 + ($gOnlyOne ne 'fail' ? 'warning: ' : '').
1.712 + 'makeUniversalDirectory: only in x86 '.
1.713 + (argumentEscape($dirX86->path()))[0].':',
1.714 + argumentEscape(keys(%onlyX86)));
1.715 + }
1.716 +
1.717 + if ($gOnlyOne eq 'fail' && (keys(%onlyPPC) || keys(%onlyX86))) {
1.718 + # Error message(s) printed above.
1.719 + return 0;
1.720 + }
1.721 +
1.722 + if ($gOnlyOne eq 'copy') {
1.723 + foreach $file (sort(keys(%onlyPPC))) {
1.724 + if (!makeUniversalInternal(0,
1.725 + FileAttrCache->new($dirPPC->path().'/'.$file),
1.726 + undef,
1.727 + $dirTarget.'/'.$file)) {
1.728 + # makeUniversalInternal will have printed an error.
1.729 + return 0;
1.730 + }
1.731 + }
1.732 +
1.733 + foreach $file (sort(keys(%onlyX86))) {
1.734 + if (!makeUniversalInternal(0,
1.735 + undef,
1.736 + FileAttrCache->new($dirX86->path().'/'.$file),
1.737 + $dirTarget.'/'.$file)) {
1.738 + # makeUniversalInternal will have printed an error.
1.739 + return 0;
1.740 + }
1.741 + }
1.742 + }
1.743 +
1.744 + return 1;
1.745 +}
1.746 +
1.747 +# makeUniversalFile($sourcePPC, $sourceX86, $targetPath)
1.748 +#
1.749 +# Creates a universal file at pathname $targetPath based on a ppc image at
1.750 +# $sourcePPC and an x86 image at $sourceX86. $sourcePPC and $sourceX86 are
1.751 +# both FileAttrCache objects. Returns true on success and false on failure.
1.752 +# On failure, diagnostics will be printed to stderr.
1.753 +#
1.754 +# The source files may be either thin Mach-O images of the appropriate
1.755 +# architecture, or fat Mach-O files that contain images of the appropriate
1.756 +# architecture.
1.757 +#
1.758 +# This function wraps the lipo utility, see lipo(1).
1.759 +sub makeUniversalFile($$$) {
1.760 + my ($sourcePPC, $sourceX86, $targetPath, @tempThinFiles, $thinPPC, $thinX86);
1.761 + ($sourcePPC, $sourceX86, $targetPath) = @_;
1.762 + $thinPPC = $sourcePPC;
1.763 + $thinX86 = $sourceX86;
1.764 +
1.765 + @tempThinFiles = ();
1.766 +
1.767 + # The source files might already be fat. They should be thinned out to only
1.768 + # contain a single architecture.
1.769 +
1.770 + my ($isFatPPC, $isFatX86);
1.771 +
1.772 + if(!defined($isFatPPC = $sourcePPC->isFat())) {
1.773 + # isFat printed its own error
1.774 + return 0;
1.775 + }
1.776 + elsif($isFatPPC) {
1.777 + $thinPPC = FileAttrCache->new($targetPath.'.ppc');
1.778 + push(@tempThinFiles, $thinPPC->path());
1.779 + if (command($gConfig{'cmd_lipo'}, '-thin', 'ppc',
1.780 + $sourcePPC->path(), '-output', $thinPPC->path()) != 0) {
1.781 + unlink(@tempThinFiles);
1.782 + return complain(1, 'lipo thin ppc failed for:',
1.783 + $sourcePPC->path(),
1.784 + $thinPPC->path());
1.785 + }
1.786 + }
1.787 +
1.788 + if(!defined($isFatX86 = $sourceX86->isFat())) {
1.789 + # isFat printed its own error
1.790 + unlink(@tempThinFiles);
1.791 + return 0;
1.792 + }
1.793 + elsif($isFatX86) {
1.794 + $thinX86 = FileAttrCache->new($targetPath.'.x86');
1.795 + push(@tempThinFiles, $thinX86->path());
1.796 + if (command($gConfig{'cmd_lipo'}, '-thin', 'i386',
1.797 + $sourceX86->path(), '-output', $thinX86->path()) != 0) {
1.798 + unlink(@tempThinFiles);
1.799 + return complain(1, 'lipo thin x86 failed for:',
1.800 + $sourceX86->path(),
1.801 + $thinX86->path());
1.802 + }
1.803 + }
1.804 +
1.805 + # The image for each architecture in the fat file will be aligned on
1.806 + # a specific boundary, default 4096 bytes, see lipo(1) -segalign.
1.807 + # Since there's no tail-padding, the fat file will consume the least
1.808 + # space on disk if the image that comes last exceeds the segment size
1.809 + # by the smallest amount.
1.810 + #
1.811 + # This saves an average of 1kB per fat file over the naive approach of
1.812 + # always putting one architecture first: average savings is 2kB per
1.813 + # file, but the naive approach would have gotten it right half of the
1.814 + # time.
1.815 +
1.816 + my ($sizePPC, $sizeX86, $thinPPCForStat, $thinX86ForStat);
1.817 +
1.818 + if (!$gDryRun) {
1.819 + $thinPPCForStat = $thinPPC;
1.820 + $thinX86ForStat = $thinX86;
1.821 + }
1.822 + else {
1.823 + # Normally, fat source files will have been converted into temporary
1.824 + # thin files. During a dry run, that doesn't happen, so fake it up
1.825 + # a little bit by always using the source file, fat or thin, for the
1.826 + # stat.
1.827 + $thinPPCForStat = $sourcePPC;
1.828 + $thinX86ForStat = $sourceX86;
1.829 + }
1.830 +
1.831 + if (!defined($sizePPC = $thinPPCForStat->statSize())) {
1.832 + unlink(@tempThinFiles);
1.833 + return complain(1, 'stat ppc: '.$!.' for:',
1.834 + $thinPPCForStat->path());
1.835 + }
1.836 + if (!defined($sizeX86 = $thinX86ForStat->statSize())) {
1.837 + unlink(@tempThinFiles);
1.838 + return complain(1, 'stat x86: '.$!.' for:',
1.839 + $thinX86ForStat->path());
1.840 + }
1.841 +
1.842 + $sizePPC = $sizePPC % 4096;
1.843 + $sizeX86 = $sizeX86 % 4096;
1.844 +
1.845 + my (@thinFiles);
1.846 +
1.847 + if ($sizePPC == 0) {
1.848 + # PPC image ends on an alignment boundary, there will be no padding before
1.849 + # starting the x86 image.
1.850 + @thinFiles = ($thinPPC->path(), $thinX86->path());
1.851 + }
1.852 + elsif ($sizeX86 == 0 || $sizeX86 > $sizePPC) {
1.853 + # x86 image ends on an alignment boundary, there will be no padding before
1.854 + # starting the PPC image, or the x86 image exceeds its alignment boundary
1.855 + # by more than the PPC image, so there will be less padding if the x86
1.856 + # comes first.
1.857 + @thinFiles = ($thinX86->path(), $thinPPC->path());
1.858 + }
1.859 + else {
1.860 + # PPC image exceeds its alignment boundary by more than the x86 image, so
1.861 + # there will be less padding if the PPC comes first.
1.862 + @thinFiles = ($thinPPC->path(), $thinX86->path());
1.863 + }
1.864 +
1.865 + my ($isExecutable);
1.866 + $isExecutable = $sourcePPC->lIsExecutable() ||
1.867 + $sourceX86->lIsExecutable();
1.868 +
1.869 + if (!$gDryRun) {
1.870 + # Ensure that the file does not yet exist.
1.871 +
1.872 + # Set the execute bits (as allowed by the umask) on the new file if any
1.873 + # execute bit is set on either old file. Yes, it is possible to have
1.874 + # proper Mach-O files without x-bits: think object files (.o) and static
1.875 + # archives (.a).
1.876 + if (!createUniqueFile($targetPath, $isExecutable ? 0777 : 0666)) {
1.877 + # createUniqueFile printed an error.
1.878 + unlink(@tempThinFiles);
1.879 + return 0;
1.880 + }
1.881 + }
1.882 +
1.883 + # Create the fat file.
1.884 + if (command($gConfig{'cmd_lipo'}, '-create', @thinFiles,
1.885 + '-output', $targetPath) != 0) {
1.886 + unlink(@tempThinFiles, $targetPath);
1.887 + return complain(1, 'lipo create fat failed for:',
1.888 + @thinFiles,
1.889 + $targetPath);
1.890 + }
1.891 +
1.892 + unlink(@tempThinFiles);
1.893 +
1.894 + if (!$gDryRun) {
1.895 + # lipo seems to think that it's free to set its own file modes that
1.896 + # ignore the umask, which is bogus when the rest of this script
1.897 + # respects the umask.
1.898 + if (!chmod(($isExecutable ? 0777 : 0666) & ~umask(), $targetPath)) {
1.899 + complain(1, 'makeUniversalFile: chmod: '.$!.' for',
1.900 + $targetPath);
1.901 + unlink($targetPath);
1.902 + return 0;
1.903 + }
1.904 + }
1.905 +
1.906 + return 1;
1.907 +}
1.908 +
1.909 +# makeUniversalInternal($isToplevel, $filePPC, $fileX86, $fileTargetPath)
1.910 +#
1.911 +# Given FileAttrCache objects $filePPC and $fileX86, compares filetypes
1.912 +# and performs the appropriate action to produce a universal file at
1.913 +# path string $fileTargetPath. $isToplevel should be true if this is
1.914 +# the recursive base and false otherwise; this controls cleanup behavior
1.915 +# (cleanup is only performed at the base, because cleanup itself is
1.916 +# recursive).
1.917 +#
1.918 +# This handles regular files by determining whether they are Mach-O files
1.919 +# and calling makeUniversalFile if so and copyIfIdentical otherwise. Symbolic
1.920 +# links are handled directly in this function by ensuring that the source link
1.921 +# targets are identical and creating a new link with the same target
1.922 +# at $fileTargetPath. Directories are handled by calling
1.923 +# makeUniversalDirectory.
1.924 +#
1.925 +# One of $filePPC and $fileX86 is permitted to be undef. In that case,
1.926 +# the defined source file is copied directly to the target if a regular
1.927 +# file, and symlinked appropriately if a symbolic link. This facilitates
1.928 +# use of $gOnlyOne = 'copy', although no $gOnlyOne checks are made in this
1.929 +# function, they are all handled in makeUniversalDirectory.
1.930 +#
1.931 +# Returns true on success. Returns false on failure, including failures
1.932 +# in other functions called.
1.933 +sub makeUniversalInternal($$$$) {
1.934 + my ($filePPC, $fileTargetPath, $fileX86, $isToplevel);
1.935 + ($isToplevel, $filePPC, $fileX86, $fileTargetPath) = @_;
1.936 +
1.937 + my ($typePPC, $typeX86);
1.938 + if (defined($filePPC) && !defined($typePPC = $filePPC->lstatType())) {
1.939 + return complain(1, 'makeUniversal: lstat ppc: '.$!.' for:',
1.940 + $filePPC->path());
1.941 + }
1.942 + if (defined($fileX86) && !defined($typeX86 = $fileX86->lstatType())) {
1.943 + return complain(1, 'makeUniversal: lstat x86: '.$!.' for:',
1.944 + $fileX86->path());
1.945 + }
1.946 +
1.947 + if (defined($filePPC) && defined($fileX86) && $typePPC != $typeX86) {
1.948 + return complain(1, 'makeUniversal: incompatible types:',
1.949 + $filePPC->path(),
1.950 + $fileX86->path());
1.951 + }
1.952 +
1.953 + # $aSourceFile will contain a FileAttrCache object that will return
1.954 + # the correct type data. It's used because it's possible for one of
1.955 + # the two source files to be undefined (indicating a straight copy).
1.956 + my ($aSourceFile);
1.957 + if (defined($filePPC)) {
1.958 + $aSourceFile = $filePPC;
1.959 + }
1.960 + else {
1.961 + $aSourceFile = $fileX86;
1.962 + }
1.963 +
1.964 + if ($aSourceFile->lIsDir()) {
1.965 + if ($gVerbosity >= 3 || $gDryRun) {
1.966 + print('mkdir '.(argumentEscape($fileTargetPath))[0]."\n");
1.967 + }
1.968 + if (!$gDryRun && !mkdir($fileTargetPath)) {
1.969 + return complain(1, 'makeUniversal: mkdir: '.$!.' for:',
1.970 + $fileTargetPath);
1.971 + }
1.972 +
1.973 + my ($rv);
1.974 +
1.975 + if (!($rv = makeUniversalDirectory($filePPC, $fileX86, $fileTargetPath))) {
1.976 + # makeUniversalDirectory printed an error.
1.977 + if ($isToplevel) {
1.978 + command($gConfig{'cmd_rm'},'-rf','--',$fileTargetPath);
1.979 + }
1.980 + }
1.981 + else {
1.982 + # Touch the directory when leaving it. If unify is being run on an
1.983 + # .app bundle, the .app might show up without an icon because the
1.984 + # system might have found the .app before it was completely built.
1.985 + # Touching it dirties it in LaunchServices' mind.
1.986 + if ($gVerbosity >= 3) {
1.987 + print('touch '.(argumentEscape($fileTargetPath))[0]."\n");
1.988 + }
1.989 + utime(undef, undef, $fileTargetPath);
1.990 + }
1.991 +
1.992 + return $rv;
1.993 + }
1.994 + elsif ($aSourceFile->lIsSymLink()) {
1.995 + my ($linkPPC, $linkX86);
1.996 + if (defined($filePPC) && !defined($linkPPC=readlink($filePPC->path()))) {
1.997 + return complain(1, 'makeUniversal: readlink ppc: '.$!.' for:',
1.998 + $filePPC->path());
1.999 + }
1.1000 + if (defined($fileX86) && !defined($linkX86=readlink($fileX86->path()))) {
1.1001 + return complain(1, 'makeUniversal: readlink x86: '.$!.' for:',
1.1002 + $fileX86->path());
1.1003 + }
1.1004 + if (defined($filePPC) && defined($fileX86) && $linkPPC ne $linkX86) {
1.1005 + return complain(1, 'makeUniversal: symbolic links differ:',
1.1006 + $filePPC->path(),
1.1007 + $fileX86->path());
1.1008 + }
1.1009 +
1.1010 + # $aLink here serves the same purpose as $aSourceFile in the enclosing
1.1011 + # block: it refers to the target of the symbolic link, whether there
1.1012 + # is one valid source or two.
1.1013 + my ($aLink);
1.1014 + if (defined($linkPPC)) {
1.1015 + $aLink = $linkPPC;
1.1016 + }
1.1017 + else {
1.1018 + $aLink = $linkX86;
1.1019 + }
1.1020 +
1.1021 + if ($gVerbosity >= 3 || $gDryRun) {
1.1022 + print('ln -s '.
1.1023 + join(' ',argumentEscape($aLink, $fileTargetPath))."\n");
1.1024 + }
1.1025 + if (!$gDryRun && !symlink($aLink, $fileTargetPath)) {
1.1026 + return complain(1, 'makeUniversal: symlink: '.$!.' for:',
1.1027 + $aLink,
1.1028 + $fileTargetPath);
1.1029 + }
1.1030 +
1.1031 + return 1;
1.1032 + }
1.1033 + elsif($aSourceFile->lIsRegularFile()) {
1.1034 + my ($machPPC, $machX86, $fileName);
1.1035 + if (!defined($filePPC) || !defined($fileX86)) {
1.1036 + # One of the source files isn't present. The right thing to do is
1.1037 + # to just copy what does exist straight over, so skip Mach-O checks.
1.1038 + $machPPC = 0;
1.1039 + $machX86 = 0;
1.1040 + if (defined($filePPC)) {
1.1041 + $fileName = $filePPC;
1.1042 + } elsif (defined($fileX86)) {
1.1043 + $fileName = $fileX86;
1.1044 + } else {
1.1045 + complain(1, "The file must exist in at least one directory");
1.1046 + exit(1);
1.1047 + }
1.1048 + }
1.1049 + else {
1.1050 + # both files exist, pick the name of one.
1.1051 + $fileName = $fileX86;
1.1052 + if (!defined($machPPC=$filePPC->isMachO())) {
1.1053 + return complain(1, 'makeUniversal: isFileMachO ppc failed for:',
1.1054 + $filePPC->path());
1.1055 + }
1.1056 + if (!defined($machX86=$fileX86->isMachO())) {
1.1057 + return complain(1, 'makeUniversal: isFileMachO x86 failed for:',
1.1058 + $fileX86->path());
1.1059 + }
1.1060 + }
1.1061 +
1.1062 + if ($machPPC != $machX86) {
1.1063 + return complain(1, 'makeUniversal: variant Mach-O attributes:',
1.1064 + $filePPC->path(),
1.1065 + $fileX86->path());
1.1066 + }
1.1067 +
1.1068 + if ($machPPC) {
1.1069 + # makeUniversalFile will print an error if it fails.
1.1070 + return makeUniversalFile($filePPC, $fileX86, $fileTargetPath);
1.1071 + }
1.1072 +
1.1073 + if (grep { $fileName->path() =~ m/$_/; } @gSortMatches) {
1.1074 + # Regular files, but should be compared with sorting first.
1.1075 + # copyIfIdenticalWhenSorted will print an error if it fails.
1.1076 + return copyIfIdenticalWhenSorted($filePPC, $fileX86, $fileTargetPath);
1.1077 + }
1.1078 +
1.1079 + # Regular file. copyIfIdentical will print an error if it fails.
1.1080 + return copyIfIdentical($filePPC, $fileX86, $fileTargetPath);
1.1081 + }
1.1082 +
1.1083 + # Special file, don't know how to handle.
1.1084 + return complain(1, 'makeUniversal: cannot handle special file:',
1.1085 + $filePPC->path(),
1.1086 + $fileX86->path());
1.1087 +}
1.1088 +
1.1089 +# usage()
1.1090 +#
1.1091 +# Give the user a hand.
1.1092 +sub usage() {
1.1093 + print STDERR (
1.1094 +"usage: unify <ppc-path> <x86-path> <universal-path>\n".
1.1095 +" [--dry-run] (print what would be done)\n".
1.1096 +" [--only-one <action>] (skip, copy, fail; default=copy)\n".
1.1097 +" [--verbosity <level>] (0, 1, 2, 3; default=2)\n");
1.1098 + return;
1.1099 +}
1.1100 +
1.1101 +# readZipCRCs($zipFile)
1.1102 +#
1.1103 +# $zipFile is the pathname to a zip file whose directory will be read.
1.1104 +# A reference to a hash is returned, with the member pathnames from the
1.1105 +# zip file as keys, and reasonably unique identifiers as values. The
1.1106 +# format of the values is not specified exactly, but does include the
1.1107 +# member CRCs and sizes and differentiates between files and directories.
1.1108 +# It specifically does not distinguish between modification times. On
1.1109 +# failure, prints a message and returns undef.
1.1110 +sub readZipCRCs($) {
1.1111 + my ($zipFile);
1.1112 + ($zipFile) = @_;
1.1113 +
1.1114 + my ($ze, $zip);
1.1115 + $zip = Archive::Zip->new();
1.1116 +
1.1117 + if (($ze = $zip->read($zipFile)) != AZ_OK) {
1.1118 + complain(1, 'readZipCRCs: read error '.$ze.' for:',
1.1119 + $zipFile);
1.1120 + return undef;
1.1121 + }
1.1122 +
1.1123 + my ($member, %memberCRCs, @memberList);
1.1124 + %memberCRCs = ();
1.1125 + @memberList = $zip->members();
1.1126 +
1.1127 + foreach $member (@memberList) {
1.1128 + # Take a few of the attributes that identify the file and stuff them into
1.1129 + # the members hash. Directories will show up with size 0 and crc32 0,
1.1130 + # so isDirectory() is used to distinguish them from empty files.
1.1131 + $memberCRCs{$member->fileName()} = join(',', $member->isDirectory() ? 1 : 0,
1.1132 + $member->uncompressedSize(),
1.1133 + $member->crc32String());
1.1134 + }
1.1135 +
1.1136 + return {%memberCRCs};
1.1137 +}
1.1138 +
1.1139 +{
1.1140 + # FileAttrCache allows various attributes about a file to be cached
1.1141 + # so that if they are needed again after first use, no system calls
1.1142 + # will be made and the program won't need to hit the disk.
1.1143 +
1.1144 + package FileAttrCache;
1.1145 +
1.1146 + # from /usr/include/mach-o/loader.h
1.1147 + use constant MH_MAGIC => 0xfeedface;
1.1148 + use constant MH_CIGAM => 0xcefaedfe;
1.1149 + use constant MH_MAGIC_64 => 0xfeedfacf;
1.1150 + use constant MH_CIGAM_64 => 0xcffaedfe;
1.1151 +
1.1152 + use Fcntl(':DEFAULT', ':mode');
1.1153 +
1.1154 + # FileAttrCache->new($path)
1.1155 + #
1.1156 + # Creates a new FileAttrCache object for the file at path $path and
1.1157 + # returns it. The cache is not primed at creation time, values are
1.1158 + # fetched lazily as they are needed.
1.1159 + sub new($$) {
1.1160 + my ($class, $path, $proto, $this);
1.1161 + ($proto, $path) = @_;
1.1162 + if (!($class = ref($proto))) {
1.1163 + $class = $proto;
1.1164 + }
1.1165 + $this = {
1.1166 + 'path' => $path,
1.1167 + 'lstat' => undef,
1.1168 + 'lstatErrno' => 0,
1.1169 + 'lstatInit' => 0,
1.1170 + 'magic' => undef,
1.1171 + 'magic2' => undef,
1.1172 + 'magicErrno' => 0,
1.1173 + 'magicErrMsg' => undef,
1.1174 + 'magicInit' => 0,
1.1175 + 'stat' => undef,
1.1176 + 'statErrno' => 0,
1.1177 + 'statInit' => 0,
1.1178 + };
1.1179 + bless($this, $class);
1.1180 + return($this);
1.1181 + }
1.1182 +
1.1183 + # $FileAttrCache->isFat()
1.1184 + #
1.1185 + # Returns true if the file is a fat Mach-O file, false if it's not, and
1.1186 + # undef if an error occurs. See /usr/include/mach-o/fat.h.
1.1187 + sub isFat($) {
1.1188 + my ($magic, $magic2, $this);
1.1189 + ($this) = @_;
1.1190 +
1.1191 + # magic() caches, there's no separate cache because isFat() doesn't hit
1.1192 + # the disk other than by calling magic().
1.1193 +
1.1194 + if (!defined($magic = $this->magic())) {
1.1195 + return undef;
1.1196 + }
1.1197 + $magic2 = $this->magic2();
1.1198 +
1.1199 + # We have to sanity check the second four bytes, because Java class
1.1200 + # files use the same magic number as Mach-O fat binaries.
1.1201 + # This logic is adapted from file(1), which says that Mach-O uses
1.1202 + # these bytes to count the number of architectures within, while
1.1203 + # Java uses it for a version number. Conveniently, there are only
1.1204 + # 18 labelled Mach-O architectures, and Java's first released
1.1205 + # class format used the version 43.0.
1.1206 + if ($magic == 0xcafebabe && $magic2 < 20) {
1.1207 + return 1;
1.1208 + }
1.1209 +
1.1210 + return 0;
1.1211 + }
1.1212 +
1.1213 + # $FileAttrCache->isMachO()
1.1214 + #
1.1215 + # Returns true if the file is a Mach-O image (including a fat file), false
1.1216 + # if it's not, and undef if an error occurs. See
1.1217 + # /usr/include/mach-o/loader.h and /usr/include/mach-o/fat.h.
1.1218 + sub isMachO($) {
1.1219 + my ($magic, $this);
1.1220 + ($this) = @_;
1.1221 +
1.1222 + # magic() caches, there's no separate cache because isMachO() doesn't hit
1.1223 + # the disk other than by calling magic().
1.1224 +
1.1225 + if (!defined($magic = $this->magic())) {
1.1226 + return undef;
1.1227 + }
1.1228 +
1.1229 + # Accept Mach-O fat files or Mach-O thin files of either endianness.
1.1230 + if ($magic == MH_MAGIC ||
1.1231 + $magic == MH_CIGAM ||
1.1232 + $magic == MH_MAGIC_64 ||
1.1233 + $magic == MH_CIGAM_64 ||
1.1234 + $this->isFat()) {
1.1235 + return 1;
1.1236 + }
1.1237 +
1.1238 + return 0;
1.1239 + }
1.1240 +
1.1241 + # $FileAttrCache->isZip()
1.1242 + #
1.1243 + # Returns true if the file is a zip file, false if it's not, and undef if
1.1244 + # an error occurs. See http://www.pkware.com/business_and_developers/developer/popups/appnote.txt .
1.1245 + sub isZip($) {
1.1246 + my ($magic, $this);
1.1247 + ($this) = @_;
1.1248 +
1.1249 + # magic() caches, there's no separate cache because isFat() doesn't hit
1.1250 + # the disk other than by calling magic().
1.1251 +
1.1252 + if (!defined($magic = $this->magic())) {
1.1253 + return undef;
1.1254 + }
1.1255 +
1.1256 + if ($magic == 0x504b0304) {
1.1257 + return 1;
1.1258 + }
1.1259 +
1.1260 + return 0;
1.1261 + }
1.1262 +
1.1263 + # $FileAttrCache->lIsExecutable()
1.1264 + #
1.1265 + # Wraps $FileAttrCache->lstat(), returning true if the file is has any,
1.1266 + # execute bit set, false if none are set, or undef if an error occurs.
1.1267 + # On error, $! is set to lstat's errno.
1.1268 + sub lIsExecutable($) {
1.1269 + my ($mode, $this);
1.1270 + ($this) = @_;
1.1271 +
1.1272 + if (!defined($mode = $this->lstatMode())) {
1.1273 + return undef;
1.1274 + }
1.1275 +
1.1276 + return $mode & (S_IXUSR | S_IXGRP | S_IXOTH);
1.1277 + }
1.1278 +
1.1279 + # $FileAttrCache->lIsDir()
1.1280 + #
1.1281 + # Wraps $FileAttrCache->lstat(), returning true if the file is a directory,
1.1282 + # false if it isn't, or undef if an error occurs. Because lstat is used,
1.1283 + # this will return false even if the file is a symlink pointing to a
1.1284 + # directory. On error, $! is set to lstat's errno.
1.1285 + sub lIsDir($) {
1.1286 + my ($type, $this);
1.1287 + ($this) = @_;
1.1288 +
1.1289 + if (!defined($type = $this->lstatType())) {
1.1290 + return undef;
1.1291 + }
1.1292 +
1.1293 + return S_ISDIR($type);
1.1294 + }
1.1295 +
1.1296 + # $FileAttrCache->lIsRegularFile()
1.1297 + #
1.1298 + # Wraps $FileAttrCache->lstat(), returning true if the file is a regular,
1.1299 + # file, false if it isn't, or undef if an error occurs. Because lstat is
1.1300 + # used, this will return false even if the file is a symlink pointing to a
1.1301 + # regular file. On error, $! is set to lstat's errno.
1.1302 + sub lIsRegularFile($) {
1.1303 + my ($type, $this);
1.1304 + ($this) = @_;
1.1305 +
1.1306 + if (!defined($type = $this->lstatType())) {
1.1307 + return undef;
1.1308 + }
1.1309 +
1.1310 + return S_ISREG($type);
1.1311 + }
1.1312 +
1.1313 + # $FileAttrCache->lIsSymLink()
1.1314 + #
1.1315 + # Wraps $FileAttrCache->lstat(), returning true if the file is a symbolic,
1.1316 + # link, false if it isn't, or undef if an error occurs. On error, $! is
1.1317 + # set to lstat's errno.
1.1318 + sub lIsSymLink($) {
1.1319 + my ($type, $this);
1.1320 + ($this) = @_;
1.1321 +
1.1322 + if (!defined($type = $this->lstatType())) {
1.1323 + return undef;
1.1324 + }
1.1325 +
1.1326 + return S_ISLNK($type);
1.1327 + }
1.1328 +
1.1329 + # $FileAttrCache->lstat()
1.1330 + #
1.1331 + # Wraps the lstat system call, providing a cache to speed up multiple
1.1332 + # lstat calls for the same file. See lstat(2) and lstat in perlfunc(1).
1.1333 + sub lstat($) {
1.1334 + my (@stat, $this);
1.1335 + ($this) = @_;
1.1336 +
1.1337 + # Use the cached lstat result.
1.1338 + if ($$this{'lstatInit'}) {
1.1339 + if (defined($$this{'lstatErrno'})) {
1.1340 + $! = $$this{'lstatErrno'};
1.1341 + }
1.1342 + return @{$$this{'lstat'}};
1.1343 + }
1.1344 + $$this{'lstatInit'} = 1;
1.1345 +
1.1346 + if (!(@stat = CORE::lstat($$this{'path'}))) {
1.1347 + $$this{'lstatErrno'} = $!;
1.1348 + }
1.1349 +
1.1350 + $$this{'lstat'} = [@stat];
1.1351 + return @stat;
1.1352 + }
1.1353 +
1.1354 + # $FileAttrCache->lstatMode()
1.1355 + #
1.1356 + # Wraps $FileAttrCache->lstat(), returning the mode bits from the st_mode
1.1357 + # field, or undef if an error occurs. On error, $! is set to lstat's
1.1358 + # errno.
1.1359 + sub lstatMode($) {
1.1360 + my (@stat, $this);
1.1361 + ($this) = @_;
1.1362 +
1.1363 + if (!(@stat = $this->lstat())) {
1.1364 + return undef;
1.1365 + }
1.1366 +
1.1367 + return S_IMODE($stat[2]);
1.1368 + }
1.1369 +
1.1370 + # $FileAttrCache->lstatType()
1.1371 + #
1.1372 + # Wraps $FileAttrCache->lstat(), returning the type bits from the st_mode
1.1373 + # field, or undef if an error occurs. On error, $! is set to lstat's
1.1374 + # errno.
1.1375 + sub lstatType($) {
1.1376 + my (@stat, $this);
1.1377 + ($this) = @_;
1.1378 +
1.1379 + if (!(@stat = $this->lstat())) {
1.1380 + return undef;
1.1381 + }
1.1382 +
1.1383 + return S_IFMT($stat[2]);
1.1384 + }
1.1385 +
1.1386 + # $FileAttrCache->magic()
1.1387 + #
1.1388 + # Returns the "magic number" for the file by reading its first four bytes
1.1389 + # as a big-endian unsigned 32-bit integer and returning the result. If an
1.1390 + # error occurs, returns undef and prints diagnostic messages to stderr. If
1.1391 + # the file is shorter than 32 bits, returns -1. A cache is provided to
1.1392 + # speed multiple magic calls for the same file.
1.1393 + sub magic($) {
1.1394 + my ($this);
1.1395 + ($this) = @_;
1.1396 +
1.1397 + # Use the cached magic result.
1.1398 + if ($$this{'magicInit'}) {
1.1399 + if (defined($$this{'magicErrno'})) {
1.1400 + if (defined($$this{'magicErrMsg'})) {
1.1401 + complain(1, 'FileAttrCache::magic: '.$$this{'magicErrMsg'}.' for:',
1.1402 + $$this{'path'});
1.1403 + }
1.1404 + $! = $$this{'magicErrno'};
1.1405 + }
1.1406 + return $$this{'magic'};
1.1407 + }
1.1408 +
1.1409 + $$this{'magicInit'} = 1;
1.1410 +
1.1411 + my ($fh);
1.1412 + if (!sysopen($fh, $$this{'path'}, O_RDONLY)) {
1.1413 + $$this{'magicErrno'} = $!;
1.1414 + $$this{'magicErrMsg'} = 'open "'.$$this{'path'}.'": '.$!;
1.1415 + complain(1, 'FileAttrCache::magic: '.$$this{'magicErrMsg'}.' for:',
1.1416 + $$this{'path'});
1.1417 + return undef;
1.1418 + }
1.1419 +
1.1420 + $! = 0;
1.1421 + my ($bytes, $magic, $bytes2, $magic2);
1.1422 + if (!defined($bytes = sysread($fh, $magic, 4))) {
1.1423 + $$this{'magicErrno'} = $!;
1.1424 + $$this{'magicErrMsg'} = 'read "'.$$this{'path'}.'": '.$!;
1.1425 + complain(1, 'FileAttrCache::magic: '.$$this{'magicErrMsg'}.' for:',
1.1426 + $$this{'path'});
1.1427 + close($fh);
1.1428 + return undef;
1.1429 + }
1.1430 + else {
1.1431 + $bytes2 = sysread($fh, $magic2, 4);
1.1432 + }
1.1433 +
1.1434 + close($fh);
1.1435 +
1.1436 + if ($bytes != 4) {
1.1437 + # The file is too short, didn't read a magic number. This isn't really
1.1438 + # an error. Return an unlikely value.
1.1439 + $$this{'magic'} = -1;
1.1440 + $$this{'magic2'} = -1;
1.1441 + return -1;
1.1442 + }
1.1443 + if ($bytes2 != 4) {
1.1444 + # File is too short to read a second 4 bytes.
1.1445 + $magic2 = -1;
1.1446 + }
1.1447 +
1.1448 + $$this{'magic'} = unpack('N', $magic);
1.1449 + $$this{'magic2'} = unpack('N', $magic2);
1.1450 + return $$this{'magic'};
1.1451 + }
1.1452 +
1.1453 + # $FileAttrCache->magic2()
1.1454 + #
1.1455 + # Returns the second four bytes of the file as a 32-bit little endian number.
1.1456 + # See magic(), above for more info.
1.1457 + sub magic2($) {
1.1458 + my ($this);
1.1459 + ($this) = @_;
1.1460 +
1.1461 + # we do the actual work (and cache it) in magic().
1.1462 + if (!$$this{'magicInit'}) {
1.1463 + my $magic = $$this->magic();
1.1464 + }
1.1465 +
1.1466 + return $$this{'magic2'};
1.1467 + }
1.1468 +
1.1469 + # $FileAttrCache->path()
1.1470 + #
1.1471 + # Returns the file's pathname.
1.1472 + sub path($) {
1.1473 + my ($this);
1.1474 + ($this) = @_;
1.1475 + return $$this{'path'};
1.1476 + }
1.1477 +
1.1478 + # $FileAttrCache->stat()
1.1479 + #
1.1480 + # Wraps the stat system call, providing a cache to speed up multiple
1.1481 + # stat calls for the same file. If lstat() has already been called and
1.1482 + # the file is not a symbolic link, the cached lstat() result will be used.
1.1483 + # See stat(2) and lstat in perlfunc(1).
1.1484 + sub stat($) {
1.1485 + my (@stat, $this);
1.1486 + ($this) = @_;
1.1487 +
1.1488 + # Use the cached stat result.
1.1489 + if ($$this{'statInit'}) {
1.1490 + if (defined($$this{'statErrno'})) {
1.1491 + $! = $$this{'statErrno'};
1.1492 + }
1.1493 + return @{$$this{'stat'}};
1.1494 + }
1.1495 +
1.1496 + $$this{'statInit'} = 1;
1.1497 +
1.1498 + # If lstat has already been called, and the file isn't a symbolic link,
1.1499 + # use the cached lstat result.
1.1500 + if ($$this{'lstatInit'} && !$$this{'lstatErrno'} &&
1.1501 + !S_ISLNK(${$$this{'lstat'}}[2])) {
1.1502 + $$this{'stat'} = $$this{'lstat'};
1.1503 + return @{$$this{'stat'}};
1.1504 + }
1.1505 +
1.1506 + if (!(@stat = CORE::stat($$this{'path'}))) {
1.1507 + $$this{'statErrno'} = $!;
1.1508 + }
1.1509 +
1.1510 + $$this{'stat'} = [@stat];
1.1511 + return @stat;
1.1512 + }
1.1513 +
1.1514 + # $FileAttrCache->statSize()
1.1515 + #
1.1516 + # Wraps $FileAttrCache->stat(), returning the st_size field, or undef
1.1517 + # undef if an error occurs. On error, $! is set to stat's errno.
1.1518 + sub statSize($) {
1.1519 + my (@stat, $this);
1.1520 + ($this) = @_;
1.1521 +
1.1522 + if (!(@stat = $this->lstat())) {
1.1523 + return undef;
1.1524 + }
1.1525 +
1.1526 + return $stat[7];
1.1527 + }
1.1528 +}
