build/macosx/universal/unify

   1 #!/usr/bin/perl
   2 # ***** BEGIN LICENSE BLOCK *****
   3 # Version: MPL 1.1/GPL 2.0/LGPL 2.1
   4 #
   5 # The contents of this file are subject to the Mozilla Public License Version
   6 # 1.1 (the "License"); you may not use this file except in compliance with
   7 # the License. You may obtain a copy of the License at
   8 # http://www.mozilla.org/MPL/
   9 #
  10 # Software distributed under the License is distributed on an "AS IS" basis,
  11 # WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
  12 # for the specific language governing rights and limitations under the
  13 # License.
  14 #
  15 # The Original Code is the Mozilla Mac OS X Universal Binary Packaging System
  16 #
  17 # The Initial Developer of the Original Code is Google Inc.
  18 # Portions created by the Initial Developer are Copyright (C) 2006
  19 # the Initial Developer. All Rights Reserved.
  20 #
  21 # Contributor(s):
  22 #  Mark Mentovai <mark@moxienet.com> (Original Author)
  23 #
  24 # Alternatively, the contents of this file may be used under the terms of
  25 # either the GNU General Public License Version 2 or later (the "GPL"), or
  26 # the GNU Lesser General Public License Version 2.1 or later (the "LGPL"),
  27 # in which case the provisions of the GPL or the LGPL are applicable instead
  28 # of those above. If you wish to allow use of your version of this file only
  29 # under the terms of either the GPL or the LGPL, and not to allow others to
  30 # use your version of this file under the terms of the MPL, indicate your
  31 # decision by deleting the provisions above and replace them with the notice
  32 # and other provisions required by the GPL or the LGPL. If you do not delete
  33 # the provisions above, a recipient may use your version of this file under
  34 # the terms of any one of the MPL, the GPL or the LGPL.
  35 #
  36 # ***** END LICENSE BLOCK *****
  37
  38 use strict;
  39 use warnings;
  40
  41 =pod
  42
  43 =head1 NAME
  44
  45 B<unify> - Mac OS X universal binary packager
  46
  47 =head1 SYNOPSIS
  48
  49 B<unify>
  50 I<ppc-path>
  51 I<x86-path>
  52 I<universal-path>
  53 [B<--dry-run>]
  54 [B<--only-one> I<action>]
  55 [B<--verbosity> I<level>]
  56
  57 =head1 DESCRIPTION
  58
  59 I<unify> merges any two architecture-specific files or directory trees
  60 into a single file or tree suitable for use on either architecture as a
  61 "fat" or "universal binary."
  62
  63 Architecture-specific Mach-O files will be merged into fat Mach-O files
  64 using L<lipo(1)>.  Non-Mach-O files in the architecture-specific trees
  65 are compared to ensure that they are equivalent before copying.  Symbolic
  66 links are permitted in the architecture-specific trees and will cause
  67 identical links to be created in the merged tree, provided that the source
  68 links have identical targets.  Directories are processed recursively.
  69
  70 If the architecture-specific source trees contain zip archives (including
  71 jar files) that are not identical according to a byte-for-byte check, they
  72 are still assumed to be equivalent if both archives contain exactly the
  73 same members with identical checksums and sizes.
  74
  75 Behavior when one architecture-specific tree contains files that the other
  76 does not is controlled by the B<--only-one> option.
  77
  78 If Mach-O files cannot be merged using L<lipo(1)>, zip archives are not
  79 equivalent, regular files are not identical, or any other error occurs,
  80 B<unify> will fail with an exit status of 1.  Diagnostic messages are
  81 typically printed to stderr; this behavior can be controlled with the
  82 B<--verbosity> option.
  83
  84 =head1 OPTIONS
  85
  86 =over 5
  87
  88 =item I<ppc-path>
  89
  90 =item I<x86-path>
  91
  92 The paths to directory trees containing PowerPC and x86 builds,
  93 respectively.  I<ppc-path> and I<x86-path> are permitted to contain files
  94 that are already "fat," and only the appropriate architecture's images will
  95 be used.
  96
  97 I<ppc-path> and I<x86-path> are also permitted to both be files, in which
  98 case B<unify> operates solely on those files, and produces an appropriate
  99 merged file at I<target-path>.
 100
 101 =item I<target-path>
 102
 103 The path to the merged file or directory tree.  This path will be created,
 104 and it must not exist prior to running B<unify>.
 105
 106 =item B<--dry-run>
 107
 108 When specified, the commands that would be executed are printed, without
 109 actually executing them.  Note that B<--dry-run> and the equivalent
 110 B<--verbosity> level during "wet" runs may print equivalent commands when
 111 no commands are in fact executed: certain operations are handled internally
 112 within B<unify>, and an approximation of a command that performs a similar
 113 task is printed.
 114
 115 =item B<--only-one> I<action>
 116
 117 Controls handling of files that are only present in one of the two source
 118 trees.  I<action> may be:
 119   skip - These files are skipped.
 120   copy - These files are copied from the tree in which they exist.
 121   fail - When this condition occurs, it is treated as an error.
 122
 123 The default I<action> is copy.
 124
 125 =item B<--verbosity> I<level>
 126
 127 Adjusts the level of loudness of B<unify>.  The possible values for
 128 I<level> are:
 129   0 - B<unify> never prints anything.
 130       (Other programs that B<unify> calls may still print messages.)
 131   1 - Fatal error messages are printed to stderr.
 132   2 - Nonfatal warnings are printed to stderr.
 133   3 - Commands are printed to stdout as they are executed.
 134
 135 The default I<level> is 2.
 136
 137 =back
 138
 139 =head1 EXAMPLES
 140
 141 =over 5
 142
 143 =item Create a universal .app bundle from two architecture-specific .app
 144 bundles:
 145
 146 unify --only-one copy ppc/dist/firefox/Firefox.app
 147   x86/dist/firefox/Firefox.app universal/Firefox.app
 148   --verbosity 3
 149
 150 =item Merge two identical architecture-specific trees:
 151
 152 unify --only-one fail /usr/local /nfs/x86/usr/local
 153   /tmp/usrlocal.fat
 154
 155 =back
 156
 157 =head1 REQUIREMENTS
 158
 159 The only esoteric requirement of B<unify> is that the L<lipo(1)> command
 160 be available.  It is present on Mac OS X systems at least as early as
 161 10.3.9, and probably earlier.  Mac OS X 10.4 ("Tiger") or later are
 162 recommended.
 163
 164 =head1 LICENSE
 165
 166 MPL 1.1/GPL 2.0/LGPL 2.1.  Your choice
 167
 168 =head1 AUTHOR
 169
 170 The software was initially written by Mark Mentovai; copyright 2006
 171 Google Inc.
 172
 173 =head1 SEE ALSO
 174
 175 L<cmp(1)>, L<ditto(1)>, L<lipo(1)>
 176
 177 =cut
 178
 179 use Archive::Zip(':ERROR_CODES');
 180 use Errno;
 181 use Fcntl;
 182 use File::Compare;
 183 use File::Copy;
 184 use Getopt::Long;
 185
 186 my (%gConfig, $gDryRun, $gOnlyOne, $gVerbosity);
 187
 188 sub argumentEscape(@);
 189 sub command(@);
 190 sub compareZipArchives($$);
 191 sub complain($$@);
 192 sub copyIfIdentical($$$);
 193 sub createUniqueFile($$);
 194 sub makeUniversal($$$);
 195 sub makeUniversalDirectory($$$);
 196 sub makeUniversalInternal($$$$);
 197 sub makeUniversalFile($$$);
 198 sub usage();
 199 sub readZipCRCs($);
 200
 201 {
 202   package FileAttrCache;
 203
 204   sub new($$);
 205
 206   sub isFat($);
 207   sub isMachO($);
 208   sub isZip($);
 209   sub lIsDir($);
 210   sub lIsExecutable($);
 211   sub lIsRegularFile($);
 212   sub lIsSymLink($);
 213   sub lstat($);
 214   sub lstatMode($);
 215   sub lstatType($);
 216   sub magic($);
 217   sub path($);
 218   sub stat($);
 219   sub statSize($);
 220 }
 221
 222 %gConfig = (
 223   'cmd_lipo' => 'lipo',
 224   'cmd_rm'   => 'rm',
 225 );
 226
 227 $gDryRun = 0;
 228 $gOnlyOne = 'copy';
 229 $gVerbosity = 2;
 230
 231 Getopt::Long::Configure('pass_through');
 232 GetOptions('dry-run'     => \$gDryRun,
 233            'only-one=s'  => \$gOnlyOne,
 234            'verbosity=i' => \$gVerbosity,
 235            'config=s'    => \%gConfig); # "hidden" option not in usage()
 236
 237 if (scalar(@ARGV) != 3 || $gVerbosity < 0 || $gVerbosity > 3 ||
 238     ($gOnlyOne ne 'skip' && $gOnlyOne ne 'copy' && $gOnlyOne ne 'fail')) {
 239   usage();
 240   exit(1);
 241 }
 242
 243 if (!makeUniversal($ARGV[0],$ARGV[1],$ARGV[2])) {
 244   # makeUniversal or something it called will have printed an error.
 245   exit(1);
 246 }
 247
 248 exit(0);
 249
 250 # argumentEscape(@arguments)
 251 #
 252 # Takes a list of @arguments and makes them shell-safe.
 253 sub argumentEscape(@) {
 254   my (@arguments);
 255   @arguments = @_;
 256
 257   my ($argument, @argumentsOut);
 258   foreach $argument (@arguments) {
 259     $argument =~ s%([^A-Za-z0-9_\-/.=+,])%\\$1%g;
 260     push(@argumentsOut, $argument);
 261   }
 262
 263   return @argumentsOut;
 264 }
 265
 266 # command(@arguments)
 267 #
 268 # Runs the specified command by calling system(@arguments).  If $gDryRun
 269 # is true, the command is printed but not executed, and 0 is returned.
 270 # if $gVerbosity is greater than 1, the command is printed before being
 271 # executed.  When the command is executed, the system() return value will
 272 # be returned.  stdout and stderr are left connected for command output.
 273 sub command(@) {
 274   my (@arguments);
 275   @arguments = @_;
 276   if ($gVerbosity >= 3 || $gDryRun) {
 277     print(join(' ', argumentEscape(@arguments))."\n");
 278   }
 279   if ($gDryRun) {
 280     return 0;
 281   }
 282   return system(@arguments);
 283 }
 284
 285 # compareZipArchives($zip1, $zip2)
 286 #
 287 # Given two pathnames to zip archives, determines whether or not they are
 288 # functionally identical.  Returns true if they are, false if they differ in
 289 # some substantial way, and undef if an error occurs.  If the zip files
 290 # differ, diagnostic messages are printed indicating how they differ.
 291 #
 292 # Zip files will differ if any of the members are different as defined by
 293 # readZipCRCs, which consider CRCs, sizes, and file types as stored in the
 294 # file header.  Timestamps are not considered.  Zip files also differ if one
 295 # file contains members that the other one does not.  $gOnlyOne has no
 296 # effect on this behavior.
 297 sub compareZipArchives($$) {
 298   my ($zip1, $zip2);
 299   ($zip1, $zip2) = @_;
 300
 301   my ($CRCHash1, $CRCHash2);
 302   if (!defined($CRCHash1 = readZipCRCs($zip1))) {
 303     # readZipCRCs printed an error.
 304     return undef;
 305   }
 306   if (!defined($CRCHash2 = readZipCRCs($zip2))) {
 307     # readZipCRCs printed an error.
 308     return undef;
 309   }
 310
 311   my (@diffCRCs, @onlyInZip1);
 312   @diffCRCs = ();
 313   @onlyInZip1 = ();
 314
 315   my ($memberName);
 316   foreach $memberName (keys(%$CRCHash1)) {
 317     if (!exists($$CRCHash2{$memberName})) {
 318       # The member is present in $zip1 but not $zip2.
 319       push(@onlyInZip1, $memberName);
 320     }
 321     elsif ($$CRCHash1{$memberName} ne $$CRCHash2{$memberName}) {
 322       # The member is present in both archives but its CRC or some other
 323       # other critical attribute isn't identical.
 324       push(@diffCRCs, $memberName);
 325     }
 326     delete($$CRCHash2{$memberName});
 327   }
 328
 329   # If any members remain in %CRCHash2, it's because they're not present
 330   # in $zip1.
 331   my (@onlyInZip2);
 332   @onlyInZip2 = keys(%$CRCHash2);
 333
 334   if (scalar(@onlyInZip1) + scalar(@onlyInZip2) + scalar(@diffCRCs)) {
 335     complain(1, 'compareZipArchives: zip archives differ:',
 336              $zip1,
 337              $zip2);
 338     if (scalar(@onlyInZip1)) {
 339       complain(1, 'compareZipArchives: members only in former:',
 340                @onlyInZip1);
 341     }
 342     if (scalar(@onlyInZip2)) {
 343       complain(1, 'compareZipArchives: members only in latter:',
 344                @onlyInZip2);
 345     }
 346     if (scalar(@diffCRCs)) {
 347       complain(1, 'compareZipArchives: members differ:',
 348                @diffCRCs);
 349     }
 350     return 0;
 351   }
 352
 353   return 1;
 354 }
 355
 356 # complain($severity, $message, @list)
 357 #
 358 # Prints $message to stderr if $gVerbosity allows it for severity level
 359 # $severity.  @list is a list of words that will be shell-escaped and printed
 360 # after $message, one per line, intended to be used, for example, to list
 361 # arguments to a call that failed.
 362 #
 363 # Expected severity levels are 1 for hard errors and 2 for non-fatal warnings.
 364 #
 365 # Always returns false as a convenience, so callers can return complain's
 366 # return value when it is used to signal errors.
 367 sub complain($$@) {
 368   my ($severity, $message, @list);
 369   ($severity, $message, @list) = @_;
 370
 371   if ($gVerbosity >= $severity) {
 372     print STDERR ($0.': '.$message."\n");
 373
 374     my ($item);
 375     while ($item = shift(@list)) {
 376       print STDERR ('  '.(argumentEscape($item))[0].
 377                     (scalar(@list)?',':'')."\n");
 378     }
 379   }
 380
 381   return 0;
 382 }
 383
 384 # copyIfIdentical($source1, $source2, $target)
 385 #
 386 # $source1 and $source2 are FileAttrCache objects that are compared, and if
 387 # identical, copied to path string $target.  The comparison is initially
 388 # done as a byte-for-byte comparison, but if the files differ and appear to
 389 # be zip archives, compareZipArchives is called to determine whether
 390 # files that are not byte-for-byte identical are equivalent archives.
 391 #
 392 # Returns true on success, false for files that are not identical or
 393 # equivalent archives, and undef if an error occurs.
 394 #
 395 # One of $source1 and $source2 is permitted to be undef.  In this event,
 396 # whichever source is defined is copied directly to $target without performing
 397 # any comparisons.  This enables the $gOnlyOne = 'copy' mode, which is
 398 # driven by makeUniversalDirectory and makeUniversalInternal.
 399 sub copyIfIdentical($$$) {
 400   my ($source1, $source2, $target);
 401   ($source1, $source2, $target) = @_;
 402
 403   if (!defined($source1)) {
 404     # If there's only one source file, make it the first file.  Order
 405     # isn't important here, and this makes it possible to use
 406     # defined($source2) as the switch, and to always copy from $source1.
 407     $source1 = $source2;
 408     $source2 = undef;
 409   }
 410
 411   if (defined($source2)) {
 412     # Only do the comparisons if there are two source files.  If there's
 413     # only one source file, skip the comparisons and go straight to the
 414     # copy operation.
 415     if ($gVerbosity >= 3 || $gDryRun) {
 416       print('cmp -s '.
 417             join(' ',argumentEscape($source1->path(), $source2->path()))."\n");
 418     }
 419     my ($comparison);
 420     if (!defined($comparison = compare($source1->path(), $source2->path())) ||
 421         $comparison == -1) {
 422       return complain(1, 'copyIfIdentical: compare: '.$!.' while comparing:',
 423                       $source1->path(),
 424                       $source2->path());
 425     }
 426     elsif ($comparison != 0) {
 427       my ($zip1, $zip2);
 428       if (defined($zip1 = $source1->isZip()) &&
 429           defined($zip2 = $source2->isZip()) &&
 430           $zip1 && $zip2) {
 431         my ($zipComparison);
 432         if (!defined($zipComparison = compareZipArchives($source1->path(),
 433                                                          $source2->path)) ||
 434             !$zipComparison) {
 435           # An error occurred or the zip files aren't sufficiently identical.
 436           # compareZipArchives will have printed an error message.
 437           return 0;
 438         }
 439         # The zip files were compared successfully, and they both contain
 440         # all of the same members, and all of their members' CRCs are
 441         # identical.  For the purposes of this script, the zip files can be
 442         # treated as identical, so reset $comparison.
 443         $comparison = 0;
 444       }
 445     }
 446     if ($comparison != 0) {
 447       return complain(1, 'copyIfIdentical: files differ:',
 448                       $source1->path(),
 449                       $source2->path());
 450     }
 451   }
 452
 453   if ($gVerbosity >= 3 || $gDryRun) {
 454     print('cp '.
 455           join(' ',argumentEscape($source1->path(), $target))."\n");
 456   }
 457
 458   if (!$gDryRun) {
 459     my ($isExecutable);
 460
 461     # Set the execute bits (as allowed by the umask) on the new file if any
 462     # execute bit is set on either old file.
 463     $isExecutable = $source1->lIsExecutable() ||
 464                     (defined($source2) && $source2->lIsExecutable());
 465
 466     if (!createUniqueFile($target, $isExecutable ? 0777 : 0666)) {
 467       # createUniqueFile printed an error.
 468       return 0;
 469     }
 470
 471     if (!copy($source1->path(), $target)) {
 472       complain(1, 'copyIfIdentical: copy: '.$!.' while copying',
 473                $source1->path(),
 474                $target);
 475       unlink($target);
 476       return 0;
 477     }
 478   }
 479
 480   return 1;
 481 }
 482
 483 # createUniqueFile($path, $mode)
 484 #
 485 # Creates a new plain empty file at pathname $path, provided it does not
 486 # yet exist.  $mode is used as the file mode.  The actual file's mode will
 487 # be modified by the effective umask.  Returns false if the file could
 488 # not be created, setting $! to the error.  An error message is printed
 489 # in the event of failure.
 490 sub createUniqueFile($$) {
 491   my ($path, $mode);
 492   ($path, $mode) = @_;
 493
 494   my ($fh);
 495   if (!sysopen($fh, $path, O_WRONLY | O_CREAT | O_EXCL, $mode)) {
 496     return complain(1, 'createUniqueFile: open: '.$!.' for:',
 497                     $path);
 498   }
 499   close($fh);
 500
 501   return 1;
 502 }
 503
 504 # makeUniversal($pathPPC, $pathX86, $pathTarget)
 505 #
 506 # The top-level call.  $pathPPC, $pathX86, and $pathTarget are strings
 507 # identifying the ppc and x86 files or directories to merge and the location
 508 # to merge them to.  Returns false on failure and true on success.
 509 sub makeUniversal($$$) {
 510   my ($pathTarget, $pathPPC, $pathX86);
 511   ($pathPPC, $pathX86, $pathTarget) = @_;
 512
 513   my ($filePPC, $fileX86);
 514   $filePPC = FileAttrCache->new($pathPPC);
 515   $fileX86 = FileAttrCache->new($pathX86);
 516
 517   return makeUniversalInternal(1, $filePPC, $fileX86, $pathTarget);
 518 }
 519
 520 # makeUniversalDirectory($dirPPC, $dirX86, $dirTarget)
 521 #
 522 # This is part of the heart of recursion.  $dirPPC and $dirX86 are
 523 # FileAttrCache objects designating the source ppc and x86 directories to
 524 # merge into a universal directory at $dirTarget, a string.  For each file
 525 # in $dirPPC and $dirX86, makeUniversalInternal is called.
 526 # makeUniversalInternal will call back into makeUniversalDirectory for
 527 # directories, thus completing the recursion.  If a failure is encountered
 528 # in ths function or in makeUniversalInternal or anything that it calls,
 529 # false is returned, otherwise, true is returned.
 530 #
 531 # If there are files present in one source directory but not both, the
 532 # value of $gOnlyOne controls the behavior.  If $gOnlyOne is 'copy', the
 533 # single source file is copied into $pathTarget.  If it is 'skip', it is
 534 # skipped.  If it is 'fail', such files will trigger makeUniversalDirectory
 535 # to fail.
 536 #
 537 # If either source directory is undef, it is treated as having no files.
 538 # This facilitates deep recursion when entire directories are only present
 539 # in one source when $gOnlyOne = 'copy'.
 540 sub makeUniversalDirectory($$$) {
 541   my ($dirPPC, $dirX86, $dirTarget);
 542   ($dirPPC, $dirX86, $dirTarget) = @_;
 543
 544   my ($dh, @filesPPC, @filesX86);
 545
 546   @filesPPC = ();
 547   if (defined($dirPPC)) {
 548     if (!opendir($dh, $dirPPC->path())) {
 549       return complain(1, 'makeUniversalDirectory: opendir ppc: '.$!.' for:',
 550                       $dirPPC->path());
 551     }
 552     @filesPPC = readdir($dh);
 553     closedir($dh);
 554   }
 555
 556   @filesX86 = ();
 557   if (defined($dirX86)) {
 558     if (!opendir($dh, $dirX86->path())) {
 559       return complain(1, 'makeUniversalDirectory: opendir x86: '.$!.' for:',
 560                       $dirX86->path());
 561      }
 562     @filesX86 = readdir($dh);
 563     closedir($dh);
 564   }
 565
 566   my (%common, $file, %onlyPPC, %onlyX86);
 567
 568   %onlyPPC = ();
 569   foreach $file (@filesPPC) {
 570     if ($file eq '.' || $file eq '..') {
 571       next;
 572     }
 573     $onlyPPC{$file}=1;
 574   }
 575
 576   %common = ();
 577   %onlyX86 = ();
 578   foreach $file (@filesX86) {
 579     if ($file eq '.' || $file eq '..') {
 580       next;
 581     }
 582     if ($onlyPPC{$file}) {
 583       delete $onlyPPC{$file};
 584       $common{$file}=1;
 585     }
 586     else {
 587       $onlyX86{$file}=1;
 588     }
 589   }
 590
 591   # First, handle files common to both.
 592   foreach $file (sort(keys(%common))) {
 593     if (!makeUniversalInternal(0,
 594                                FileAttrCache->new($dirPPC->path().'/'.$file),
 595                                FileAttrCache->new($dirX86->path().'/'.$file),
 596                                $dirTarget.'/'.$file)) {
 597       # makeUniversalInternal will have printed an error.
 598       return 0;
 599     }
 600   }
 601
 602   # Handle files found only in a single directory here.  There are three
 603   # options, dictated by $gOnlyOne: fail if files are only present in
 604   # one directory, skip any files only present in one directory, or copy
 605   # these files straight over to the target directory.  In any event,
 606   # a message will be printed indicating that the file trees don't match
 607   # exactly.
 608   if (keys(%onlyPPC)) {
 609     complain(($gOnlyOne eq 'fail' ? 1 : 2),
 610              ($gOnlyOne ne 'fail' ? 'warning: ' : '').
 611              'makeUniversalDirectory: only in ppc '.
 612              (argumentEscape($dirPPC->path()))[0].':',
 613              argumentEscape(keys(%onlyPPC)));
 614   }
 615
 616   if (keys(%onlyX86)) {
 617     complain(($gOnlyOne eq 'fail' ? 1 : 2),
 618              ($gOnlyOne ne 'fail' ? 'warning: ' : '').
 619              'makeUniversalDirectory: only in x86 '.
 620              (argumentEscape($dirX86->path()))[0].':',
 621              argumentEscape(keys(%onlyX86)));
 622   }
 623
 624   if ($gOnlyOne eq 'fail' && (keys(%onlyPPC) || keys(%onlyX86))) {
 625     # Error message(s) printed above.
 626     return 0;
 627   }
 628
 629   if ($gOnlyOne eq 'copy') {
 630     foreach $file (sort(keys(%onlyPPC))) {
 631       if (!makeUniversalInternal(0,
 632                                  FileAttrCache->new($dirPPC->path().'/'.$file),
 633                                  undef,
 634                                  $dirTarget.'/'.$file)) {
 635         # makeUniversalInternal will have printed an error.
 636         return 0;
 637       }
 638     }
 639
 640     foreach $file (sort(keys(%onlyX86))) {
 641       if (!makeUniversalInternal(0,
 642                                  undef,
 643                                  FileAttrCache->new($dirX86->path().'/'.$file),
 644                                  $dirTarget.'/'.$file)) {
 645         # makeUniversalInternal will have printed an error.
 646         return 0;
 647       }
 648     }
 649   }
 650
 651   return 1;
 652 }
 653
 654 # makeUniversalFile($sourcePPC, $sourceX86, $targetPath)
 655 #
 656 # Creates a universal file at pathname $targetPath based on a ppc image at
 657 # $sourcePPC and an x86 image at $sourceX86.  $sourcePPC and $sourceX86 are
 658 # both FileAttrCache objects.  Returns true on success and false on failure.
 659 # On failure, diagnostics will be printed to stderr.
 660 #
 661 # The source files may be either thin Mach-O images of the appropriate
 662 # architecture, or fat Mach-O files that contain images of the appropriate
 663 # architecture.
 664 #
 665 # This function wraps the lipo utility, see lipo(1).
 666 sub makeUniversalFile($$$) {
 667   my ($sourcePPC, $sourceX86, $targetPath, @tempThinFiles, $thinPPC, $thinX86);
 668   ($sourcePPC, $sourceX86, $targetPath) = @_;
 669   $thinPPC = $sourcePPC;
 670   $thinX86 = $sourceX86;
 671
 672   @tempThinFiles = ();
 673
 674   # The source files might already be fat.  They should be thinned out to only
 675   # contain a single architecture.
 676
 677   my ($isFatPPC, $isFatX86);
 678
 679   if(!defined($isFatPPC = $sourcePPC->isFat())) {
 680     # isFat printed its own error
 681     return 0;
 682   }
 683   elsif($isFatPPC) {
 684     $thinPPC = FileAttrCache->new($targetPath.'.ppc');
 685     push(@tempThinFiles, $thinPPC->path());
 686     if (command($gConfig{'cmd_lipo'}, '-thin', 'ppc',
 687                 $sourcePPC->path(), '-output', $thinPPC->path()) != 0) {
 688       unlink(@tempThinFiles);
 689       return complain(1, 'lipo thin ppc failed for:',
 690                       $sourcePPC->path(),
 691                       $thinPPC->path());
 692     }
 693   }
 694
 695   if(!defined($isFatX86 = $sourceX86->isFat())) {
 696     # isFat printed its own error
 697     unlink(@tempThinFiles);
 698     return 0;
 699   }
 700   elsif($isFatX86) {
 701     $thinX86 = FileAttrCache->new($targetPath.'.x86');
 702     push(@tempThinFiles, $thinX86->path());
 703     if (command($gConfig{'cmd_lipo'}, '-thin', 'i386',
 704                 $sourceX86->path(), '-output', $thinX86->path()) != 0) {
 705       unlink(@tempThinFiles);
 706       return complain(1, 'lipo thin x86 failed for:',
 707                       $sourceX86->path(),
 708                       $thinX86->path());
 709     }
 710   }
 711
 712   # The image for each architecture in the fat file will be aligned on
 713   # a specific boundary, default 4096 bytes, see lipo(1) -segalign.
 714   # Since there's no tail-padding, the fat file will consume the least
 715   # space on disk if the image that comes last exceeds the segment size
 716   # by the smallest amount.
 717   #
 718   # This saves an average of 1kB per fat file over the naive approach of
 719   # always putting one architecture first: average savings is 2kB per
 720   # file, but the naive approach would have gotten it right half of the
 721   # time.
 722
 723   my ($sizePPC, $sizeX86, $thinPPCForStat, $thinX86ForStat);
 724
 725   if (!$gDryRun) {
 726     $thinPPCForStat = $thinPPC;
 727     $thinX86ForStat = $thinX86;
 728   }
 729   else {
 730     # Normally, fat source files will have been converted into temporary
 731     # thin files.  During a dry run, that doesn't happen, so fake it up
 732     # a little bit by always using the source file, fat or thin, for the
 733     # stat.
 734     $thinPPCForStat = $sourcePPC;
 735     $thinX86ForStat = $sourceX86;
 736   }
 737
 738   if (!defined($sizePPC = $thinPPCForStat->statSize())) {
 739     unlink(@tempThinFiles);
 740     return complain(1, 'stat ppc: '.$!.' for:',
 741                     $thinPPCForStat->path());
 742   }
 743   if (!defined($sizeX86 = $thinX86ForStat->statSize())) {
 744     unlink(@tempThinFiles);
 745     return complain(1, 'stat x86: '.$!.' for:',
 746                     $thinX86ForStat->path());
 747   }
 748
 749   $sizePPC = $sizePPC % 4096;
 750   $sizeX86 = $sizeX86 % 4096;
 751
 752   my (@thinFiles);
 753
 754   if ($sizePPC == 0) {
 755     # PPC image ends on an alignment boundary, there will be no padding before
 756     # starting the x86 image.
 757     @thinFiles = ($thinPPC->path(), $thinX86->path());
 758   }
 759   elsif ($sizeX86 == 0 || $sizeX86 > $sizePPC) {
 760     # x86 image ends on an alignment boundary, there will be no padding before
 761     # starting the PPC image, or the x86 image exceeds its alignment boundary
 762     # by more than the PPC image, so there will be less padding if the x86
 763     # comes first.
 764     @thinFiles = ($thinX86->path(), $thinPPC->path());
 765   }
 766   else {
 767     # PPC image exceeds its alignment boundary by more than the x86 image, so
 768     # there will be less padding if the PPC comes first.
 769     @thinFiles = ($thinPPC->path(), $thinX86->path());
 770   }
 771
 772   my ($isExecutable);
 773   $isExecutable = $sourcePPC->lIsExecutable() ||
 774                   $sourceX86->lIsExecutable();
 775
 776   if (!$gDryRun) {
 777     # Ensure that the file does not yet exist.
 778
 779     # Set the execute bits (as allowed by the umask) on the new file if any
 780     # execute bit is set on either old file.  Yes, it is possible to have
 781     # proper Mach-O files without x-bits: think object files (.o) and static
 782     # archives (.a).
 783     if (!createUniqueFile($targetPath, $isExecutable ? 0777 : 0666)) {
 784       # createUniqueFile printed an error.
 785       unlink(@tempThinFiles);
 786       return 0;
 787     }
 788   }
 789
 790   # Create the fat file.
 791   if (command($gConfig{'cmd_lipo'}, '-create', @thinFiles,
 792               '-output', $targetPath) != 0) {
 793     unlink(@tempThinFiles, $targetPath);
 794     return complain(1, 'lipo create fat failed for:',
 795                     @thinFiles,
 796                     $targetPath);
 797   }
 798
 799   unlink(@tempThinFiles);
 800
 801   if (!$gDryRun) {
 802     # lipo seems to think that it's free to set its own file modes that
 803     # ignore the umask, which is bogus when the rest of this script
 804     # respects the umask.
 805     if (!chmod(($isExecutable ? 0777 : 0666) & ~umask(), $targetPath)) {
 806       complain(1, 'makeUniversalFile: chmod: '.$!.' for',
 807                $targetPath);
 808       unlink($targetPath);
 809       return 0;
 810     }
 811   }
 812
 813   return 1;
 814 }
 815
 816 # makeUniversalInternal($isToplevel, $filePPC, $fileX86, $fileTargetPath)
 817 #
 818 # Given FileAttrCache objects $filePPC and $fileX86, compares filetypes
 819 # and performs the appropriate action to produce a universal file at
 820 # path string $fileTargetPath.  $isToplevel should be true if this is
 821 # the recursive base and false otherwise; this controls cleanup behavior
 822 # (cleanup is only performed at the base, because cleanup itself is
 823 # recursive).
 824 #
 825 # This handles regular files by determining whether they are Mach-O files
 826 # and calling makeUniversalFile if so and copyIfIdentical otherwise.  Symbolic
 827 # links are handled directly in this function by ensuring that the source link
 828 # targets are identical and creating a new link with the same target
 829 # at $fileTargetPath.  Directories are handled by calling
 830 # makeUniversalDirectory.
 831 #
 832 # One of $filePPC and $fileX86 is permitted to be undef.  In that case,
 833 # the defined source file is copied directly to the target if a regular
 834 # file, and symlinked appropriately if a symbolic link.  This facilitates
 835 # use of $gOnlyOne = 'copy', although no $gOnlyOne checks are made in this
 836 # function, they are all handled in makeUniversalDirectory.
 837 #
 838 # Returns true on success.  Returns false on failure, including failures
 839 # in other functions called.
 840 sub makeUniversalInternal($$$$) {
 841   my ($filePPC, $fileTargetPath, $fileX86, $isToplevel);
 842   ($isToplevel, $filePPC, $fileX86, $fileTargetPath) = @_;
 843
 844   my ($typePPC, $typeX86);
 845   if (defined($filePPC) && !defined($typePPC = $filePPC->lstatType())) {
 846     return complain(1, 'makeUniversal: lstat ppc: '.$!.' for:',
 847                     $filePPC->path());
 848   }
 849   if (defined($fileX86) && !defined($typeX86 = $fileX86->lstatType())) {
 850     return complain(1, 'makeUniversal: lstat x86: '.$!.' for:',
 851                     $fileX86->path());
 852   }
 853
 854   if (defined($filePPC) && defined($fileX86) && $typePPC != $typeX86) {
 855     return complain(1, 'makeUniversal: incompatible types:',
 856                     $filePPC->path(),
 857                     $fileX86->path());
 858   }
 859
 860   # $aSourceFile will contain a FileAttrCache object that will return
 861   # the correct type data.  It's used because it's possible for one of
 862   # the two source files to be undefined (indicating a straight copy).
 863   my ($aSourceFile);
 864   if (defined($filePPC)) {
 865     $aSourceFile = $filePPC;
 866   }
 867   else {
 868     $aSourceFile = $fileX86;
 869   }
 870
 871   if ($aSourceFile->lIsDir()) {
 872     if ($gVerbosity >= 3 || $gDryRun) {
 873       print('mkdir '.(argumentEscape($fileTargetPath))[0]."\n");
 874     }
 875     if (!$gDryRun && !mkdir($fileTargetPath)) {
 876       return complain(1, 'makeUniversal: mkdir: '.$!.' for:',
 877                       $fileTargetPath);
 878     }
 879
 880     my ($rv);
 881
 882     if (!($rv = makeUniversalDirectory($filePPC, $fileX86, $fileTargetPath))) {
 883       # makeUniversalDirectory printed an error.
 884       if ($isToplevel) {
 885         command($gConfig{'cmd_rm'},'-rf','--',$fileTargetPath);
 886       }
 887     }
 888     else {
 889       # Touch the directory when leaving it.  If unify is being run on an
 890       # .app bundle, the .app might show up without an icon because the
 891       # system might have found the .app before it was completely built.
 892       # Touching it dirties it in LaunchServices' mind.
 893       if ($gVerbosity >= 3) {
 894         print('touch '.(argumentEscape($fileTargetPath))[0]."\n");
 895       }
 896       utime(undef, undef, $fileTargetPath);
 897     }
 898
 899     return $rv;
 900   }
 901   elsif ($aSourceFile->lIsSymLink()) {
 902     my ($linkPPC, $linkX86);
 903     if (defined($filePPC) && !defined($linkPPC=readlink($filePPC->path()))) {
 904       return complain(1, 'makeUniversal: readlink ppc: '.$!.' for:',
 905                       $filePPC->path());
 906     }
 907     if (defined($fileX86) && !defined($linkX86=readlink($fileX86->path()))) {
 908       return complain(1, 'makeUniversal: readlink x86: '.$!.' for:',
 909                       $fileX86->path());
 910     }
 911     if (defined($filePPC) && defined($fileX86) && $linkPPC ne $linkX86) {
 912       return complain(1, 'makeUniversal: symbolic links differ:',
 913                       $filePPC->path(),
 914                       $fileX86->path());
 915     }
 916
 917     # $aLink here serves the same purpose as $aSourceFile in the enclosing
 918     # block: it refers to the target of the symbolic link, whether there
 919     # is one valid source or two.
 920     my ($aLink);
 921     if (defined($linkPPC)) {
 922       $aLink = $linkPPC;
 923     }
 924     else {
 925       $aLink = $linkX86;
 926     }
 927
 928     if ($gVerbosity >= 3 || $gDryRun) {
 929       print('ln -s '.
 930             join(' ',argumentEscape($aLink, $fileTargetPath))."\n");
 931     }
 932     if (!$gDryRun && !symlink($aLink, $fileTargetPath)) {
 933       return complain(1, 'makeUniversal: symlink: '.$!.' for:',
 934                       $aLink,
 935                       $fileTargetPath);
 936     }
 937
 938     return 1;
 939   }
 940   elsif($aSourceFile->lIsRegularFile()) {
 941     my ($machPPC, $machX86);
 942     if (!defined($filePPC) || !defined($fileX86)) {
 943       # One of the source files isn't present.  The right thing to do is
 944       # to just copy what does exist straight over, so skip Mach-O checks.
 945       $machPPC = 0;
 946       $machX86 = 0;
 947     }
 948     else {
 949       if (!defined($machPPC=$filePPC->isMachO())) {
 950         return complain(1, 'makeUniversal: isFileMachO ppc failed for:',
 951                         $filePPC->path());
 952       }
 953       if (!defined($machX86=$fileX86->isMachO())) {
 954         return complain(1, 'makeUniversal: isFileMachO x86 failed for:',
 955                         $fileX86->path());
 956       }
 957     }
 958
 959     if ($machPPC != $machX86) {
 960       return complain(1, 'makeUniversal: variant Mach-O attributes:',
 961                       $filePPC->path(),
 962                   $fileX86->path());
 963     }
 964
 965     if ($machPPC) {
 966       # makeUniversalFile will print an error if it fails.
 967       return makeUniversalFile($filePPC, $fileX86, $fileTargetPath);
 968     }
 969
 970     # Regular file.  copyIfIdentical will print an error if it fails.
 971     return copyIfIdentical($filePPC, $fileX86, $fileTargetPath);
 972   }
 973
 974   # Special file, don't know how to handle.
 975   return complain(1, 'makeUniversal: cannot handle special file:',
 976                   $filePPC->path(),
 977                   $fileX86->path());
 978 }
 979
 980 # usage()
 981 #
 982 # Give the user a hand.
 983 sub usage() {
 984   print STDERR (
 985 "usage: unify <ppc-path> <x86-path> <universal-path>\n".
 986 "            [--dry-run]           (print what would be done)\n".
 987 "            [--only-one <action>] (skip, copy, fail; default=copy)\n".
 988 "            [--verbosity <level>] (0, 1, 2, 3; default=2)\n");
 989   return;
 990 }
 991
 992 # readZipCRCs($zipFile)
 993 #
 994 # $zipFile is the pathname to a zip file whose directory will be read.
 995 # A reference to a hash is returned, with the member pathnames from the
 996 # zip file as keys, and reasonably unique identifiers as values.  The
 997 # format of the values is not specified exactly, but does include the
 998 # member CRCs and sizes and differentiates between files and directories.
 999 # It specifically does not distinguish between modification times.  On
1000 # failure, prints a message and returns undef.
1001 sub readZipCRCs($) {
1002   my ($zipFile);
1003   ($zipFile) = @_;
1004
1005   my ($ze, $zip);
1006   $zip = Archive::Zip->new();
1007
1008   if (($ze = $zip->read($zipFile)) != AZ_OK) {
1009     complain(1, 'readZipCRCs: read error '.$ze.' for:',
1010              $zipFile);
1011     return undef;
1012   }
1013
1014   my ($member, %memberCRCs, @memberList);
1015   %memberCRCs = ();
1016   @memberList = $zip->members();
1017
1018   foreach $member (@memberList) {
1019     # Take a few of the attributes that identify the file and stuff them into
1020     # the members hash.  Directories will show up with size 0 and crc32 0,
1021     # so isDirectory() is used to distinguish them from empty files.
1022     $memberCRCs{$member->fileName()} = join(',', $member->isDirectory() ? 1 : 0,
1023                                                  $member->uncompressedSize(),
1024                                                  $member->crc32String());
1025   }
1026
1027   return {%memberCRCs};
1028 }
1029
1030 {
1031   # FileAttrCache allows various attributes about a file to be cached
1032   # so that if they are needed again after first use, no system calls
1033   # will be made and the program won't need to hit the disk.
1034
1035   package FileAttrCache;
1036
1037   use Fcntl(':DEFAULT', ':mode');
1038
1039   # FileAttrCache->new($path)
1040   #
1041   # Creates a new FileAttrCache object for the file at path $path and
1042   # returns it.  The cache is not primed at creation time, values are
1043   # fetched lazily as they are needed.
1044   sub new($$) {
1045     my ($class, $path, $proto, $this);
1046     ($proto, $path) = @_;
1047     if (!($class = ref($proto))) {
1048       $class = $proto;
1049     }
1050     $this = {
1051       'path'        => $path,
1052       'lstat'       => undef,
1053       'lstatErrno'  => 0,
1054       'lstatInit'   => 0,
1055       'magic'       => undef,
1056       'magicErrno'  => 0,
1057       'magicErrMsg' => undef,
1058       'magicInit'   => 0,
1059       'stat'        => undef,
1060       'statErrno'   => 0,
1061       'statInit'    => 0,
1062     };
1063     bless($this, $class);
1064     return($this);
1065   }
1066
1067   # $FileAttrCache->isFat()
1068   #
1069   # Returns true if the file is a fat Mach-O file, false if it's not, and
1070   # undef if an error occurs.  See /usr/include/mach-o/fat.h.
1071   sub isFat($) {
1072     my ($magic, $this);
1073     ($this) = @_;
1074
1075     # magic() caches, there's no separate cache because isFat() doesn't hit
1076     # the disk other than by calling magic().
1077
1078     if (!defined($magic = $this->magic())) {
1079       return undef;
1080     }
1081
1082     if ($magic == 0xcafebabe) {
1083       return 1;
1084     }
1085
1086     return 0;
1087   }
1088
1089   # $FileAttrCache->isMachO()
1090   #
1091   # Returns true if the file is a Mach-O image (including a fat file), false
1092   # if it's not, and undef if an error occurs.  See
1093   # /usr/include/mach-o/loader.h and /usr/include/mach-o/fat.h.
1094   sub isMachO($) {
1095     my ($magic, $this);
1096     ($this) = @_;
1097
1098     # magic() caches, there's no separate cache because isMachO() doesn't hit
1099     # the disk other than by calling magic().
1100
1101     if (!defined($magic = $this->magic())) {
1102       return undef;
1103     }
1104
1105     # Accept Mach-O fat files or Mach-O thin files of either endianness.
1106     if ($magic == 0xfeedface ||
1107         $magic == 0xcefaedfe ||
1108         $magic == 0xcafebabe) {
1109       return 1;
1110     }
1111
1112     return 0;
1113   }
1114
1115   # $FileAttrCache->isZip()
1116   #
1117   # Returns true if the file is a zip file, false if it's not, and undef if
1118   # an error occurs.  See http://www.pkware.com/business_and_developers/developer/popups/appnote.txt .
1119   sub isZip($) {
1120     my ($magic, $this);
1121     ($this) = @_;
1122
1123     # magic() caches, there's no separate cache because isFat() doesn't hit
1124     # the disk other than by calling magic().
1125
1126     if (!defined($magic = $this->magic())) {
1127       return undef;
1128     }
1129
1130     if ($magic == 0x504b0304) {
1131       return 1;
1132     }
1133
1134     return 0;
1135   }
1136
1137   # $FileAttrCache->lIsExecutable()
1138   #
1139   # Wraps $FileAttrCache->lstat(), returning true if the file is has any,
1140   # execute bit set, false if none are set, or undef if an error occurs.
1141   # On error, $! is set to lstat's errno.
1142   sub lIsExecutable($) {
1143     my ($mode, $this);
1144     ($this) = @_;
1145
1146     if (!defined($mode = $this->lstatMode())) {
1147       return undef;
1148     }
1149
1150     return $mode & (S_IXUSR | S_IXGRP | S_IXOTH);
1151   }
1152
1153   # $FileAttrCache->lIsDir()
1154   #
1155   # Wraps $FileAttrCache->lstat(), returning true if the file is a directory,
1156   # false if it isn't, or undef if an error occurs.  Because lstat is used,
1157   # this will return false even if the file is a symlink pointing to a
1158   # directory.  On error, $! is set to lstat's errno.
1159   sub lIsDir($) {
1160     my ($type, $this);
1161     ($this) = @_;
1162
1163     if (!defined($type = $this->lstatType())) {
1164       return undef;
1165     }
1166
1167     return S_ISDIR($type);
1168   }
1169
1170   # $FileAttrCache->lIsRegularFile()
1171   #
1172   # Wraps $FileAttrCache->lstat(), returning true if the file is a regular,
1173   # file, false if it isn't, or undef if an error occurs.  Because lstat is
1174   # used, this will return false even if the file is a symlink pointing to a
1175   # regular file.  On error, $! is set to lstat's errno.
1176   sub lIsRegularFile($) {
1177     my ($type, $this);
1178     ($this) = @_;
1179
1180     if (!defined($type = $this->lstatType())) {
1181       return undef;
1182     }
1183
1184     return S_ISREG($type);
1185   }
1186
1187   # $FileAttrCache->lIsSymLink()
1188   #
1189   # Wraps $FileAttrCache->lstat(), returning true if the file is a symbolic,
1190   # link, false if it isn't, or undef if an error occurs.  On error, $! is
1191   # set to lstat's errno.
1192   sub lIsSymLink($) {
1193     my ($type, $this);
1194     ($this) = @_;
1195
1196     if (!defined($type = $this->lstatType())) {
1197       return undef;
1198     }
1199
1200     return S_ISLNK($type);
1201   }
1202
1203   # $FileAttrCache->lstat()
1204   #
1205   # Wraps the lstat system call, providing a cache to speed up multiple
1206   # lstat calls for the same file.  See lstat(2) and lstat in perlfunc(1).
1207   sub lstat($) {
1208     my (@stat, $this);
1209     ($this) = @_;
1210
1211     # Use the cached lstat result.
1212     if ($$this{'lstatInit'}) {
1213       if (defined($$this{'lstatErrno'})) {
1214         $! = $$this{'lstatErrno'};
1215       }
1216       return @{$$this{'lstat'}};
1217     }
1218     $$this{'lstatInit'} = 1;
1219
1220     if (!(@stat = CORE::lstat($$this{'path'}))) {
1221       $$this{'lstatErrno'} = $!;
1222     }
1223
1224     $$this{'lstat'} = [@stat];
1225     return @stat;
1226   }
1227
1228   # $FileAttrCache->lstatMode()
1229   #
1230   # Wraps $FileAttrCache->lstat(), returning the mode bits from the st_mode
1231   # field, or undef if an error occurs.  On error, $! is set to lstat's
1232   # errno.
1233   sub lstatMode($) {
1234     my (@stat, $this);
1235     ($this) = @_;
1236
1237     if (!(@stat = $this->lstat())) {
1238       return undef;
1239     }
1240
1241     return S_IMODE($stat[2]);
1242   }
1243
1244   # $FileAttrCache->lstatType()
1245   #
1246   # Wraps $FileAttrCache->lstat(), returning the type bits from the st_mode
1247   # field, or undef if an error occurs.  On error, $! is set to lstat's
1248   # errno.
1249   sub lstatType($) {
1250     my (@stat, $this);
1251     ($this) = @_;
1252
1253     if (!(@stat = $this->lstat())) {
1254       return undef;
1255     }
1256
1257     return S_IFMT($stat[2]);
1258   }
1259
1260   # $FileAttrCache->magic()
1261   #
1262   # Returns the "magic number" for the file by reading its first four bytes
1263   # as a big-endian unsigned 32-bit integer and returning the result.  If an
1264   # error occurs, returns undef and prints diagnostic messages to stderr.  If
1265   # the file is shorter than 32 bits, returns -1.  A cache is provided to
1266   # speed multiple magic calls for the same file.
1267   sub magic($) {
1268     my ($this);
1269     ($this) = @_;
1270
1271     # Use the cached magic result.
1272     if ($$this{'magicInit'}) {
1273       if (defined($$this{'magicErrno'})) {
1274         if (defined($$this{'magicErrMsg'})) {
1275           complain(1, 'FileAttrCache::magic: '.$$this{'magicErrMsg'}.' for:',
1276                    $$this{'path'});
1277         }
1278         $! = $$this{'magicErrno'};
1279       }
1280       return $$this{'magic'};
1281     }
1282
1283     $$this{'magicInit'} = 1;
1284
1285     my ($fh);
1286     if (!sysopen($fh, $$this{'path'}, O_RDONLY)) {
1287       $$this{'magicErrno'} = $!;
1288       $$this{'magicErrMsg'} = 'open "'.$$this{'path'}.'": '.$!;
1289       complain(1, 'FileAttrCache::magic: '.$$this{'magicErrMsg'}.' for:',
1290                $$this{'path'});
1291       return undef;
1292     }
1293
1294     $! = 0;
1295     my ($bytes, $magic);
1296     if (!defined($bytes = sysread($fh, $magic, 4))) {
1297       $$this{'magicErrno'} = $!;
1298       $$this{'magicErrMsg'} = 'read "'.$$this{'path'}.'": '.$!;
1299       complain(1, 'FileAttrCache::magic: '.$$this{'magicErrMsg'}.' for:',
1300                $$this{'path'});
1301       close($fh);
1302       return undef;
1303     }
1304
1305     close($fh);
1306
1307     if ($bytes != 4) {
1308       # The file is too short, didn't read a magic number.  This isn't really
1309       # an error.  Return an unlikely value.
1310       $$this{'magic'} = -1;
1311       return -1;
1312     }
1313
1314     $$this{'magic'} = unpack('N', $magic);
1315     return $$this{'magic'};
1316   }
1317
1318   # $FileAttrCache->path()
1319   #
1320   # Returns the file's pathname.
1321   sub path($) {
1322     my ($this);
1323     ($this) = @_;
1324     return $$this{'path'};
1325   }
1326
1327   # $FileAttrCache->stat()
1328   #
1329   # Wraps the stat system call, providing a cache to speed up multiple
1330   # stat calls for the same file.  If lstat() has already been called and
1331   # the file is not a symbolic link, the cached lstat() result will be used.
1332   # See stat(2) and lstat in perlfunc(1).
1333   sub stat($) {
1334     my (@stat, $this);
1335     ($this) = @_;
1336
1337     # Use the cached stat result.
1338     if ($$this{'statInit'}) {
1339       if (defined($$this{'statErrno'})) {
1340         $! = $$this{'statErrno'};
1341       }
1342       return @{$$this{'stat'}};
1343     }
1344
1345     $$this{'statInit'} = 1;
1346
1347     # If lstat has already been called, and the file isn't a symbolic link,
1348     # use the cached lstat result.
1349     if ($$this{'lstatInit'} && !$$this{'lstatErrno'} &&
1350         !S_ISLNK(${$$this{'lstat'}}[2])) {
1351       $$this{'stat'} = $$this{'lstat'};
1352       return @{$$this{'stat'}};
1353     }
1354
1355     if (!(@stat = CORE::stat($$this{'path'}))) {
1356       $$this{'statErrno'} = $!;
1357     }
1358
1359     $$this{'stat'} = [@stat];
1360     return @stat;
1361   }
1362
1363   # $FileAttrCache->statSize()
1364   #
1365   # Wraps $FileAttrCache->stat(), returning the st_size field, or undef
1366   # undef if an error occurs.  On error, $! is set to stat's errno.
1367   sub statSize($) {
1368     my (@stat, $this);
1369     ($this) = @_;
1370
1371     if (!(@stat = $this->lstat())) {
1372       return undef;
1373     }
1374
1375     return $stat[7];
1376   }
1377 }