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