The Tor Browser: build/macosx/universal/unify@b8a032363ba2

Incorporate requested changes from Mozilla in review:
https://bugzilla.mozilla.org/show_bug.cgi?id=1123480#c6

     1 #!/usr/bin/perl

     2 # This Source Code Form is subject to the terms of the Mozilla Public

     3 # License, v. 2.0. If a copy of the MPL was not distributed with this

     4 # file, You can obtain one at http://mozilla.org/MPL/2.0/.

     6 use strict;

     7 use warnings;

     9 =pod

    11 =head1 NAME

    13 B<unify> - Mac OS X universal binary packager

    15 =head1 SYNOPSIS

    17 B<unify>

    18 I<ppc-path>

    19 I<x86-path>

    20 I<universal-path>

    21 [B<--dry-run>]

    22 [B<--only-one> I<action>]

    23 [B<--verbosity> I<level>]

    24 [B<--unify-with-sort> I<regex>]

    26 =head1 DESCRIPTION

    28 I<unify> merges any two architecture-specific files or directory trees

    29 into a single file or tree suitable for use on either architecture as a

    30 "fat" or "universal binary."

    32 Architecture-specific Mach-O files will be merged into fat Mach-O files

    33 using L<lipo(1)>.  Non-Mach-O files in the architecture-specific trees

    34 are compared to ensure that they are equivalent before copying.  Symbolic

    35 links are permitted in the architecture-specific trees and will cause

    36 identical links to be created in the merged tree, provided that the source

    37 links have identical targets.  Directories are processed recursively.

    39 If the architecture-specific source trees contain zip archives (including

    40 jar files) that are not identical according to a byte-for-byte check, they

    41 are still assumed to be equivalent if both archives contain exactly the

    42 same members with identical checksums and sizes.

    44 Behavior when one architecture-specific tree contains files that the other

    45 does not is controlled by the B<--only-one> option.

    47 If Mach-O files cannot be merged using L<lipo(1)>, zip archives are not

    48 equivalent, regular files are not identical, or any other error occurs,

    49 B<unify> will fail with an exit status of 1.  Diagnostic messages are

    50 typically printed to stderr; this behavior can be controlled with the

    51 B<--verbosity> option.

    53 =head1 OPTIONS

    55 =over 5

    57 =item I<ppc-path>

    59 =item I<x86-path>

    61 The paths to directory trees containing PowerPC and x86 builds,

    62 respectively.  I<ppc-path> and I<x86-path> are permitted to contain files

    63 that are already "fat," and only the appropriate architecture's images will

    64 be used.

    66 I<ppc-path> and I<x86-path> are also permitted to both be files, in which

    67 case B<unify> operates solely on those files, and produces an appropriate

    68 merged file at I<target-path>.

    70 =item I<target-path>

    72 The path to the merged file or directory tree.  This path will be created,

    73 and it must not exist prior to running B<unify>.

    75 =item B<--dry-run>

    77 When specified, the commands that would be executed are printed, without

    78 actually executing them.  Note that B<--dry-run> and the equivalent

    79 B<--verbosity> level during "wet" runs may print equivalent commands when

    80 no commands are in fact executed: certain operations are handled internally

    81 within B<unify>, and an approximation of a command that performs a similar

    82 task is printed.

    84 =item B<--only-one> I<action>

    86 Controls handling of files that are only present in one of the two source

    87 trees.  I<action> may be:

    88   skip - These files are skipped.

    89   copy - These files are copied from the tree in which they exist.

    90   fail - When this condition occurs, it is treated as an error.

    92 The default I<action> is copy.

    94 =item B<--verbosity> I<level>

    96 Adjusts the level of loudness of B<unify>.  The possible values for

    97 I<level> are:

    98   0 - B<unify> never prints anything.

    99       (Other programs that B<unify> calls may still print messages.)

   100   1 - Fatal error messages are printed to stderr.

   101   2 - Nonfatal warnings are printed to stderr.

   102   3 - Commands are printed to stdout as they are executed.

   104 The default I<level> is 2.

   106 =item B<--unify-with-sort> I<regex>

   108 Allows merging files matching I<regex> that differ only by the ordering

   109 of the lines contained within them. The unified file will have its contents

   110 sorted. This option may be given multiple times to specify multiple

   111 regexes for matching files.

   113 =back

   115 =head1 EXAMPLES

   117 =over 5

   119 =item Create a universal .app bundle from two architecture-specific .app

   120 bundles:

   122 unify --only-one copy ppc/dist/firefox/Firefox.app

   123   x86/dist/firefox/Firefox.app universal/Firefox.app

   124   --verbosity 3

   126 =item Merge two identical architecture-specific trees:

   128 unify --only-one fail /usr/local /nfs/x86/usr/local

   129   /tmp/usrlocal.fat

   131 =back

   133 =head1 REQUIREMENTS

   135 The only esoteric requirement of B<unify> is that the L<lipo(1)> command

   136 be available.  It is present on Mac OS X systems at least as early as

   137 10.3.9, and probably earlier.  Mac OS X 10.4 ("Tiger") or later are

   138 recommended.

   140 =head1 LICENSE

   142 MPL 2.

   144 =head1 AUTHOR

   146 The software was initially written by Mark Mentovai; copyright 2006

   147 Google Inc.

   149 =head1 SEE ALSO

   151 L<cmp(1)>, L<ditto(1)>, L<lipo(1)>

   153 =cut

   155 use Archive::Zip(':ERROR_CODES');

   156 use Errno;

   157 use Fcntl;

   158 use File::Compare;

   159 use File::Copy;

   160 use Getopt::Long;

   162 my (%gConfig, $gDryRun, $gOnlyOne, $gVerbosity, @gSortMatches);

   164 sub argumentEscape(@);

   165 sub command(@);

   166 sub compareZipArchives($$);

   167 sub complain($$@);

   168 sub copyIfIdentical($$$);

   169 sub slurp($);

   170 sub get_sorted($);

   171 sub compare_sorted($$);

   172 sub copyIfIdenticalWhenSorted($$$);

   173 sub createUniqueFile($$);

   174 sub makeUniversal($$$);

   175 sub makeUniversalDirectory($$$);

   176 sub makeUniversalInternal($$$$);

   177 sub makeUniversalFile($$$);

   178 sub usage();

   179 sub readZipCRCs($);

   181 {

   182   package FileAttrCache;

   184   sub new($$);

   186   sub isFat($);

   187   sub isMachO($);

   188   sub isZip($);

   189   sub lIsDir($);

   190   sub lIsExecutable($);

   191   sub lIsRegularFile($);

   192   sub lIsSymLink($);

   193   sub lstat($);

   194   sub lstatMode($);

   195   sub lstatType($);

   196   sub magic($);

   197   sub magic2($);

   198   sub path($);

   199   sub stat($);

   200   sub statSize($);

   201 }

   203 %gConfig = (

   204   'cmd_lipo' => 'lipo',

   205   'cmd_rm'   => 'rm',

   206 );

   208 $gDryRun = 0;

   209 $gOnlyOne = 'copy';

   210 $gVerbosity = 2;

   211 @gSortMatches = ();

   213 Getopt::Long::Configure('pass_through');

   214 GetOptions('dry-run'           => \$gDryRun,

   215            'only-one=s'        => \$gOnlyOne,

   216            'verbosity=i'       => \$gVerbosity,

   217            'unify-with-sort=s' => \@gSortMatches,

   218            'config=s'          => \%gConfig); # "hidden" option not in usage()

   220 if (scalar(@ARGV) != 3 || $gVerbosity < 0 || $gVerbosity > 3 ||

   221     ($gOnlyOne ne 'skip' && $gOnlyOne ne 'copy' && $gOnlyOne ne 'fail')) {

   222   usage();

   223   exit(1);

   224 }

   226 if (!makeUniversal($ARGV[0],$ARGV[1],$ARGV[2])) {

   227   # makeUniversal or something it called will have printed an error.

   228   exit(1);

   229 }

   231 exit(0);

   233 # argumentEscape(@arguments)

   234 #

   235 # Takes a list of @arguments and makes them shell-safe.

   236 sub argumentEscape(@) {

   237   my (@arguments);

   238   @arguments = @_;

   240   my ($argument, @argumentsOut);

   241   foreach $argument (@arguments) {

   242     $argument =~ s%([^A-Za-z0-9_\-/.=+,])%\\$1%g;

   243     push(@argumentsOut, $argument);

   244   }

   246   return @argumentsOut;

   247 }

   249 # command(@arguments)

   250 #

   251 # Runs the specified command by calling system(@arguments).  If $gDryRun

   252 # is true, the command is printed but not executed, and 0 is returned.

   253 # if $gVerbosity is greater than 1, the command is printed before being

   254 # executed.  When the command is executed, the system() return value will

   255 # be returned.  stdout and stderr are left connected for command output.

   256 sub command(@) {

   257   my (@arguments);

   258   @arguments = @_;

   259   if ($gVerbosity >= 3 || $gDryRun) {

   260     print(join(' ', argumentEscape(@arguments))."\n");

   261   }

   262   if ($gDryRun) {

   263     return 0;

   264   }

   265   return system(@arguments);

   266 }

   268 # compareZipArchives($zip1, $zip2)

   269 #

   270 # Given two pathnames to zip archives, determines whether or not they are

   271 # functionally identical.  Returns true if they are, false if they differ in

   272 # some substantial way, and undef if an error occurs.  If the zip files

   273 # differ, diagnostic messages are printed indicating how they differ.

   274 #

   275 # Zip files will differ if any of the members are different as defined by

   276 # readZipCRCs, which consider CRCs, sizes, and file types as stored in the

   277 # file header.  Timestamps are not considered.  Zip files also differ if one

   278 # file contains members that the other one does not.  $gOnlyOne has no

   279 # effect on this behavior.

   280 sub compareZipArchives($$) {

   281   my ($zip1, $zip2);

   282   ($zip1, $zip2) = @_;

   284   my ($CRCHash1, $CRCHash2);

   285   if (!defined($CRCHash1 = readZipCRCs($zip1))) {

   286     # readZipCRCs printed an error.

   287     return undef;

   288   }

   289   if (!defined($CRCHash2 = readZipCRCs($zip2))) {

   290     # readZipCRCs printed an error.

   291     return undef;

   292   }

   294   my (@diffCRCs, @onlyInZip1);

   295   @diffCRCs = ();

   296   @onlyInZip1 = ();

   298   my ($memberName);

   299   foreach $memberName (keys(%$CRCHash1)) {

   300     if (!exists($$CRCHash2{$memberName})) {

   301       # The member is present in $zip1 but not $zip2.

   302       push(@onlyInZip1, $memberName);

   303     }

   304     elsif ($$CRCHash1{$memberName} ne $$CRCHash2{$memberName}) {

   305       # The member is present in both archives but its CRC or some other

   306       # other critical attribute isn't identical.

   307       push(@diffCRCs, $memberName);

   308     }

   309     delete($$CRCHash2{$memberName});

   310   }

   312   # If any members remain in %CRCHash2, it's because they're not present

   313   # in $zip1.

   314   my (@onlyInZip2);

   315   @onlyInZip2 = keys(%$CRCHash2);

   317   if (scalar(@onlyInZip1) + scalar(@onlyInZip2) + scalar(@diffCRCs)) {

   318     complain(1, 'compareZipArchives: zip archives differ:',

   319              $zip1,

   320              $zip2);

   321     if (scalar(@onlyInZip1)) {

   322       complain(1, 'compareZipArchives: members only in former:',

   323                @onlyInZip1);

   324     }

   325     if (scalar(@onlyInZip2)) {

   326       complain(1, 'compareZipArchives: members only in latter:',

   327                @onlyInZip2);

   328     }

   329     if (scalar(@diffCRCs)) {

   330       complain(1, 'compareZipArchives: members differ:',

   331                @diffCRCs);

   332     }

   333     return 0;

   334   }

   336   return 1;

   337 }

   339 # complain($severity, $message, @list)

   340 #

   341 # Prints $message to stderr if $gVerbosity allows it for severity level

   342 # $severity.  @list is a list of words that will be shell-escaped and printed

   343 # after $message, one per line, intended to be used, for example, to list

   344 # arguments to a call that failed.

   345 #

   346 # Expected severity levels are 1 for hard errors and 2 for non-fatal warnings.

   347 #

   348 # Always returns false as a convenience, so callers can return complain's

   349 # return value when it is used to signal errors.

   350 sub complain($$@) {

   351   my ($severity, $message, @list);

   352   ($severity, $message, @list) = @_;

   354   if ($gVerbosity >= $severity) {

   355     print STDERR ($0.': '.$message."\n");

   357     my ($item);

   358     while ($item = shift(@list)) {

   359       print STDERR ('  '.(argumentEscape($item))[0].

   360                     (scalar(@list)?',':'')."\n");

   361     }

   362   }

   364   return 0;

   365 }

   367 # copyIfIdentical($source1, $source2, $target)

   368 #

   369 # $source1 and $source2 are FileAttrCache objects that are compared, and if

   370 # identical, copied to path string $target.  The comparison is initially

   371 # done as a byte-for-byte comparison, but if the files differ and appear to

   372 # be zip archives, compareZipArchives is called to determine whether

   373 # files that are not byte-for-byte identical are equivalent archives.

   374 #

   375 # Returns true on success, false for files that are not identical or

   376 # equivalent archives, and undef if an error occurs.

   377 #

   378 # One of $source1 and $source2 is permitted to be undef.  In this event,

   379 # whichever source is defined is copied directly to $target without performing

   380 # any comparisons.  This enables the $gOnlyOne = 'copy' mode, which is

   381 # driven by makeUniversalDirectory and makeUniversalInternal.

   382 sub copyIfIdentical($$$) {

   383   my ($source1, $source2, $target);

   384   ($source1, $source2, $target) = @_;

   386   if (!defined($source1)) {

   387     # If there's only one source file, make it the first file.  Order

   388     # isn't important here, and this makes it possible to use

   389     # defined($source2) as the switch, and to always copy from $source1.

   390     $source1 = $source2;

   391     $source2 = undef;

   392   }

   394   if (defined($source2)) {

   395     # Only do the comparisons if there are two source files.  If there's

   396     # only one source file, skip the comparisons and go straight to the

   397     # copy operation.

   398     if ($gVerbosity >= 3 || $gDryRun) {

   399       print('cmp -s '.

   400             join(' ',argumentEscape($source1->path(), $source2->path()))."\n");

   401     }

   402     my ($comparison);

   403     if (!defined($comparison = compare($source1->path(), $source2->path())) ||

   404         $comparison == -1) {

   405       return complain(1, 'copyIfIdentical: compare: '.$!.' while comparing:',

   406                       $source1->path(),

   407                       $source2->path());

   408     }

   409     elsif ($comparison != 0) {

   410       my ($zip1, $zip2);

   411       if (defined($zip1 = $source1->isZip()) &&

   412           defined($zip2 = $source2->isZip()) &&

   413           $zip1 && $zip2) {

   414         my ($zipComparison);

   415         if (!defined($zipComparison = compareZipArchives($source1->path(),

   416                                                          $source2->path)) ||

   417             !$zipComparison) {

   418           # An error occurred or the zip files aren't sufficiently identical.

   419           # compareZipArchives will have printed an error message.

   420           return 0;

   421         }

   422         # The zip files were compared successfully, and they both contain

   423         # all of the same members, and all of their members' CRCs are

   424         # identical.  For the purposes of this script, the zip files can be

   425         # treated as identical, so reset $comparison.

   426         $comparison = 0;

   427       }

   428     }

   429     if ($comparison != 0) {

   430       return complain(1, 'copyIfIdentical: files differ:',

   431                       $source1->path(),

   432                       $source2->path());

   433     }

   434   }

   436   if ($gVerbosity >= 3 || $gDryRun) {

   437     print('cp '.

   438           join(' ',argumentEscape($source1->path(), $target))."\n");

   439   }

   441   if (!$gDryRun) {

   442     my ($isExecutable);

   444     # Set the execute bits (as allowed by the umask) on the new file if any

   445     # execute bit is set on either old file.

   446     $isExecutable = $source1->lIsExecutable() ||

   447                     (defined($source2) && $source2->lIsExecutable());

   449     if (!createUniqueFile($target, $isExecutable ? 0777 : 0666)) {

   450       # createUniqueFile printed an error.

   451       return 0;

   452     }

   454     if (!copy($source1->path(), $target)) {

   455       complain(1, 'copyIfIdentical: copy: '.$!.' while copying',

   456                $source1->path(),

   457                $target);

   458       unlink($target);

   459       return 0;

   460     }

   461   }

   463   return 1;

   464 }

   466 # slurp($file)

   467 #

   468 # Read the contents of $file into an array and return it.

   469 # Returns undef on error.

   470 sub slurp($) {

   471   my $file = $_[0];

   472   open FILE, $file or return undef;

   473   my @lines = <FILE>;

   474   close FILE;

   475   return @lines;

   476 }

   478 # get_sorted($file)

   479 # Get the sorted lines of a file as a list, normalizing a newline on the last line if necessary.

   480 sub get_sorted($) {

   481   my ($file) = @_;

   482   my @lines = slurp($file);

   483   my $lastline = $lines[-1];

   484   if (!($lastline =~ /\n/)) {

   485     $lines[-1] = $lastline . "\n";

   486   }

   487   return sort(@lines);

   488 }

   490 # compare_sorted($file1, $file2)

   491 #

   492 # Read the contents of both files into arrays, sort the arrays,

   493 # and then compare the two arrays for equality.

   494 #

   495 # Returns 0 if the sorted array contents are equal, or 1 if not.

   496 # Returns undef on error.

   497 sub compare_sorted($$) {

   498   my ($file1, $file2) = @_;

   499   my @lines1 = get_sorted($file1);

   500   my @lines2 = get_sorted($file2);

   502   return undef if !@lines1 || !@lines2;

   503   return 1 unless scalar @lines1 == scalar @lines2;

   505   for (my $i = 0; $i < scalar @lines1; $i++) {

   506     return 1 if $lines1[$i] ne $lines2[$i];

   507   }

   508   return 0;

   509 }

   511 # copyIfIdenticalWhenSorted($source1, $source2, $target)

   512 #

   513 # $source1 and $source2 are FileAttrCache objects that are compared, and if

   514 # identical, copied to path string $target.  The comparison is done by

   515 # sorting the individual lines within the two files and comparing the results.

   516 #

   517 # Returns true on success, false for files that are not equivalent,

   518 # and undef if an error occurs.

   519 sub copyIfIdenticalWhenSorted($$$) {

   520   my ($source1, $source2, $target);

   521   ($source1, $source2, $target) = @_;

   523   if ($gVerbosity >= 3 || $gDryRun) {

   524     print('cmp -s '.

   525           join(' ',argumentEscape($source1->path(), $source2->path()))."\n");

   526   }

   527   my ($comparison);

   528   if (!defined($comparison = compare_sorted($source1->path(),

   529                                             $source2->path())) ||

   530       $comparison == -1) {

   531     return complain(1, 'copyIfIdenticalWhenSorted: compare: '.$!

   532                     .' while comparing:',

   533                       $source1->path(),

   534                       $source2->path());

   535   }

   536   if ($comparison != 0) {

   537     return complain(1, 'copyIfIdenticalWhenSorted: files differ:',

   538                     $source1->path(),

   539                     $source2->path());

   540   }

   542   if ($gVerbosity >= 3 || $gDryRun) {

   543     print('cp '.

   544           join(' ',argumentEscape($source1->path(), $target))."\n");

   545   }

   547   if (!$gDryRun) {

   548     my ($isExecutable);

   550     # Set the execute bits (as allowed by the umask) on the new file if any

   551     # execute bit is set on either old file.

   552     $isExecutable = $source1->lIsExecutable() ||

   553                     (defined($source2) && $source2->lIsExecutable());

   555     if (!createUniqueFile($target, $isExecutable ? 0777 : 0666)) {

   556       # createUniqueFile printed an error.

   557       return 0;

   558     }

   560     if (!copy($source1->path(), $target)) {

   561       complain(1, 'copyIfIdenticalWhenSorted: copy: '.$!

   562                .' while copying',

   563                $source1->path(),

   564                $target);

   565       unlink($target);

   566       return 0;

   567     }

   568   }

   570   return 1;

   571 }

   573 # createUniqueFile($path, $mode)

   574 #

   575 # Creates a new plain empty file at pathname $path, provided it does not

   576 # yet exist.  $mode is used as the file mode.  The actual file's mode will

   577 # be modified by the effective umask.  Returns false if the file could

   578 # not be created, setting $! to the error.  An error message is printed

   579 # in the event of failure.

   580 sub createUniqueFile($$) {

   581   my ($path, $mode);

   582   ($path, $mode) = @_;

   584   my ($fh);

   585   if (!sysopen($fh, $path, O_WRONLY | O_CREAT | O_EXCL, $mode)) {

   586     return complain(1, 'createUniqueFile: open: '.$!.' for:',

   587                     $path);

   588   }

   589   close($fh);

   591   return 1;

   592 }

   594 # makeUniversal($pathPPC, $pathX86, $pathTarget)

   595 #

   596 # The top-level call.  $pathPPC, $pathX86, and $pathTarget are strings

   597 # identifying the ppc and x86 files or directories to merge and the location

   598 # to merge them to.  Returns false on failure and true on success.

   599 sub makeUniversal($$$) {

   600   my ($pathTarget, $pathPPC, $pathX86);

   601   ($pathPPC, $pathX86, $pathTarget) = @_;

   603   my ($filePPC, $fileX86);

   604   $filePPC = FileAttrCache->new($pathPPC);

   605   $fileX86 = FileAttrCache->new($pathX86);

   607   return makeUniversalInternal(1, $filePPC, $fileX86, $pathTarget);

   608 }

   610 # makeUniversalDirectory($dirPPC, $dirX86, $dirTarget)

   611 #

   612 # This is part of the heart of recursion.  $dirPPC and $dirX86 are

   613 # FileAttrCache objects designating the source ppc and x86 directories to

   614 # merge into a universal directory at $dirTarget, a string.  For each file

   615 # in $dirPPC and $dirX86, makeUniversalInternal is called.

   616 # makeUniversalInternal will call back into makeUniversalDirectory for

   617 # directories, thus completing the recursion.  If a failure is encountered

   618 # in ths function or in makeUniversalInternal or anything that it calls,

   619 # false is returned, otherwise, true is returned.

   620 #

   621 # If there are files present in one source directory but not both, the

   622 # value of $gOnlyOne controls the behavior.  If $gOnlyOne is 'copy', the

   623 # single source file is copied into $pathTarget.  If it is 'skip', it is

   624 # skipped.  If it is 'fail', such files will trigger makeUniversalDirectory

   625 # to fail.

   626 #

   627 # If either source directory is undef, it is treated as having no files.

   628 # This facilitates deep recursion when entire directories are only present

   629 # in one source when $gOnlyOne = 'copy'.

   630 sub makeUniversalDirectory($$$) {

   631   my ($dirPPC, $dirX86, $dirTarget);

   632   ($dirPPC, $dirX86, $dirTarget) = @_;

   634   my ($dh, @filesPPC, @filesX86);

   636   @filesPPC = ();

   637   if (defined($dirPPC)) {

   638     if (!opendir($dh, $dirPPC->path())) {

   639       return complain(1, 'makeUniversalDirectory: opendir ppc: '.$!.' for:',

   640                       $dirPPC->path());

   641     }

   642     @filesPPC = readdir($dh);

   643     closedir($dh);

   644   }

   646   @filesX86 = ();

   647   if (defined($dirX86)) {

   648     if (!opendir($dh, $dirX86->path())) {

   649       return complain(1, 'makeUniversalDirectory: opendir x86: '.$!.' for:',

   650                       $dirX86->path());

   651      }

   652     @filesX86 = readdir($dh);

   653     closedir($dh);

   654   }

   656   my (%common, $file, %onlyPPC, %onlyX86);

   658   %onlyPPC = ();

   659   foreach $file (@filesPPC) {

   660     if ($file eq '.' || $file eq '..') {

   661       next;

   662     }

   663     $onlyPPC{$file}=1;

   664   }

   666   %common = ();

   667   %onlyX86 = ();

   668   foreach $file (@filesX86) {

   669     if ($file eq '.' || $file eq '..') {

   670       next;

   671     }

   672     if ($onlyPPC{$file}) {

   673       delete $onlyPPC{$file};

   674       $common{$file}=1;

   675     }

   676     else {

   677       $onlyX86{$file}=1;

   678     }

   679   }

   681   # First, handle files common to both.

   682   foreach $file (sort(keys(%common))) {

   683     if (!makeUniversalInternal(0,

   684                                FileAttrCache->new($dirPPC->path().'/'.$file),

   685                                FileAttrCache->new($dirX86->path().'/'.$file),

   686                                $dirTarget.'/'.$file)) {

   687       # makeUniversalInternal will have printed an error.

   688       return 0;

   689     }

   690   }

   692   # Handle files found only in a single directory here.  There are three

   693   # options, dictated by $gOnlyOne: fail if files are only present in

   694   # one directory, skip any files only present in one directory, or copy

   695   # these files straight over to the target directory.  In any event,

   696   # a message will be printed indicating that the file trees don't match

   697   # exactly.

   698   if (keys(%onlyPPC)) {

   699     complain(($gOnlyOne eq 'fail' ? 1 : 2),

   700              ($gOnlyOne ne 'fail' ? 'warning: ' : '').

   701              'makeUniversalDirectory: only in ppc '.

   702              (argumentEscape($dirPPC->path()))[0].':',

   703              argumentEscape(keys(%onlyPPC)));

   704   }

   706   if (keys(%onlyX86)) {

   707     complain(($gOnlyOne eq 'fail' ? 1 : 2),

   708              ($gOnlyOne ne 'fail' ? 'warning: ' : '').

   709              'makeUniversalDirectory: only in x86 '.

   710              (argumentEscape($dirX86->path()))[0].':',

   711              argumentEscape(keys(%onlyX86)));

   712   }

   714   if ($gOnlyOne eq 'fail' && (keys(%onlyPPC) || keys(%onlyX86))) {

   715     # Error message(s) printed above.

   716     return 0;

   717   }

   719   if ($gOnlyOne eq 'copy') {

   720     foreach $file (sort(keys(%onlyPPC))) {

   721       if (!makeUniversalInternal(0,

   722                                  FileAttrCache->new($dirPPC->path().'/'.$file),

   723                                  undef,

   724                                  $dirTarget.'/'.$file)) {

   725         # makeUniversalInternal will have printed an error.

   726         return 0;

   727       }

   728     }

   730     foreach $file (sort(keys(%onlyX86))) {

   731       if (!makeUniversalInternal(0,

   732                                  undef,

   733                                  FileAttrCache->new($dirX86->path().'/'.$file),

   734                                  $dirTarget.'/'.$file)) {

   735         # makeUniversalInternal will have printed an error.

   736         return 0;

   737       }

   738     }

   739   }

   741   return 1;

   742 }

   744 # makeUniversalFile($sourcePPC, $sourceX86, $targetPath)

   745 #

   746 # Creates a universal file at pathname $targetPath based on a ppc image at

   747 # $sourcePPC and an x86 image at $sourceX86.  $sourcePPC and $sourceX86 are

   748 # both FileAttrCache objects.  Returns true on success and false on failure.

   749 # On failure, diagnostics will be printed to stderr.

   750 #

   751 # The source files may be either thin Mach-O images of the appropriate

   752 # architecture, or fat Mach-O files that contain images of the appropriate

   753 # architecture.

   754 #

   755 # This function wraps the lipo utility, see lipo(1).

   756 sub makeUniversalFile($$$) {

   757   my ($sourcePPC, $sourceX86, $targetPath, @tempThinFiles, $thinPPC, $thinX86);

   758   ($sourcePPC, $sourceX86, $targetPath) = @_;

   759   $thinPPC = $sourcePPC;

   760   $thinX86 = $sourceX86;

   762   @tempThinFiles = ();

   764   # The source files might already be fat.  They should be thinned out to only

   765   # contain a single architecture.

   767   my ($isFatPPC, $isFatX86);

   769   if(!defined($isFatPPC = $sourcePPC->isFat())) {

   770     # isFat printed its own error

   771     return 0;

   772   }

   773   elsif($isFatPPC) {

   774     $thinPPC = FileAttrCache->new($targetPath.'.ppc');

   775     push(@tempThinFiles, $thinPPC->path());

   776     if (command($gConfig{'cmd_lipo'}, '-thin', 'ppc',

   777                 $sourcePPC->path(), '-output', $thinPPC->path()) != 0) {

   778       unlink(@tempThinFiles);

   779       return complain(1, 'lipo thin ppc failed for:',

   780                       $sourcePPC->path(),

   781                       $thinPPC->path());

   782     }

   783   }

   785   if(!defined($isFatX86 = $sourceX86->isFat())) {

   786     # isFat printed its own error

   787     unlink(@tempThinFiles);

   788     return 0;

   789   }

   790   elsif($isFatX86) {

   791     $thinX86 = FileAttrCache->new($targetPath.'.x86');

   792     push(@tempThinFiles, $thinX86->path());

   793     if (command($gConfig{'cmd_lipo'}, '-thin', 'i386',

   794                 $sourceX86->path(), '-output', $thinX86->path()) != 0) {

   795       unlink(@tempThinFiles);

   796       return complain(1, 'lipo thin x86 failed for:',

   797                       $sourceX86->path(),

   798                       $thinX86->path());

   799     }

   800   }

   802   # The image for each architecture in the fat file will be aligned on

   803   # a specific boundary, default 4096 bytes, see lipo(1) -segalign.

   804   # Since there's no tail-padding, the fat file will consume the least

   805   # space on disk if the image that comes last exceeds the segment size

   806   # by the smallest amount.

   807   #

   808   # This saves an average of 1kB per fat file over the naive approach of

   809   # always putting one architecture first: average savings is 2kB per

   810   # file, but the naive approach would have gotten it right half of the

   811   # time.

   813   my ($sizePPC, $sizeX86, $thinPPCForStat, $thinX86ForStat);

   815   if (!$gDryRun) {

   816     $thinPPCForStat = $thinPPC;

   817     $thinX86ForStat = $thinX86;

   818   }

   819   else {

   820     # Normally, fat source files will have been converted into temporary

   821     # thin files.  During a dry run, that doesn't happen, so fake it up

   822     # a little bit by always using the source file, fat or thin, for the

   823     # stat.

   824     $thinPPCForStat = $sourcePPC;

   825     $thinX86ForStat = $sourceX86;

   826   }

   828   if (!defined($sizePPC = $thinPPCForStat->statSize())) {

   829     unlink(@tempThinFiles);

   830     return complain(1, 'stat ppc: '.$!.' for:',

   831                     $thinPPCForStat->path());

   832   }

   833   if (!defined($sizeX86 = $thinX86ForStat->statSize())) {

   834     unlink(@tempThinFiles);

   835     return complain(1, 'stat x86: '.$!.' for:',

   836                     $thinX86ForStat->path());

   837   }

   839   $sizePPC = $sizePPC % 4096;

   840   $sizeX86 = $sizeX86 % 4096;

   842   my (@thinFiles);

   844   if ($sizePPC == 0) {

   845     # PPC image ends on an alignment boundary, there will be no padding before

   846     # starting the x86 image.

   847     @thinFiles = ($thinPPC->path(), $thinX86->path());

   848   }

   849   elsif ($sizeX86 == 0 || $sizeX86 > $sizePPC) {

   850     # x86 image ends on an alignment boundary, there will be no padding before

   851     # starting the PPC image, or the x86 image exceeds its alignment boundary

   852     # by more than the PPC image, so there will be less padding if the x86

   853     # comes first.

   854     @thinFiles = ($thinX86->path(), $thinPPC->path());

   855   }

   856   else {

   857     # PPC image exceeds its alignment boundary by more than the x86 image, so

   858     # there will be less padding if the PPC comes first.

   859     @thinFiles = ($thinPPC->path(), $thinX86->path());

   860   }

   862   my ($isExecutable);

   863   $isExecutable = $sourcePPC->lIsExecutable() ||

   864                   $sourceX86->lIsExecutable();

   866   if (!$gDryRun) {

   867     # Ensure that the file does not yet exist.

   869     # Set the execute bits (as allowed by the umask) on the new file if any

   870     # execute bit is set on either old file.  Yes, it is possible to have

   871     # proper Mach-O files without x-bits: think object files (.o) and static

   872     # archives (.a).

   873     if (!createUniqueFile($targetPath, $isExecutable ? 0777 : 0666)) {

   874       # createUniqueFile printed an error.

   875       unlink(@tempThinFiles);

   876       return 0;

   877     }

   878   }

   880   # Create the fat file.

   881   if (command($gConfig{'cmd_lipo'}, '-create', @thinFiles,

   882               '-output', $targetPath) != 0) {

   883     unlink(@tempThinFiles, $targetPath);

   884     return complain(1, 'lipo create fat failed for:',

   885                     @thinFiles,

   886                     $targetPath);

   887   }

   889   unlink(@tempThinFiles);

   891   if (!$gDryRun) {

   892     # lipo seems to think that it's free to set its own file modes that

   893     # ignore the umask, which is bogus when the rest of this script

   894     # respects the umask.

   895     if (!chmod(($isExecutable ? 0777 : 0666) & ~umask(), $targetPath)) {

   896       complain(1, 'makeUniversalFile: chmod: '.$!.' for',

   897                $targetPath);

   898       unlink($targetPath);

   899       return 0;

   900     }

   901   }

   903   return 1;

   904 }

   906 # makeUniversalInternal($isToplevel, $filePPC, $fileX86, $fileTargetPath)

   907 #

   908 # Given FileAttrCache objects $filePPC and $fileX86, compares filetypes

   909 # and performs the appropriate action to produce a universal file at

   910 # path string $fileTargetPath.  $isToplevel should be true if this is

   911 # the recursive base and false otherwise; this controls cleanup behavior

   912 # (cleanup is only performed at the base, because cleanup itself is

   913 # recursive).

   914 #

   915 # This handles regular files by determining whether they are Mach-O files

   916 # and calling makeUniversalFile if so and copyIfIdentical otherwise.  Symbolic

   917 # links are handled directly in this function by ensuring that the source link

   918 # targets are identical and creating a new link with the same target

   919 # at $fileTargetPath.  Directories are handled by calling

   920 # makeUniversalDirectory.

   921 #

   922 # One of $filePPC and $fileX86 is permitted to be undef.  In that case,

   923 # the defined source file is copied directly to the target if a regular

   924 # file, and symlinked appropriately if a symbolic link.  This facilitates

   925 # use of $gOnlyOne = 'copy', although no $gOnlyOne checks are made in this

   926 # function, they are all handled in makeUniversalDirectory.

   927 #

   928 # Returns true on success.  Returns false on failure, including failures

   929 # in other functions called.

   930 sub makeUniversalInternal($$$$) {

   931   my ($filePPC, $fileTargetPath, $fileX86, $isToplevel);

   932   ($isToplevel, $filePPC, $fileX86, $fileTargetPath) = @_;

   934   my ($typePPC, $typeX86);

   935   if (defined($filePPC) && !defined($typePPC = $filePPC->lstatType())) {

   936     return complain(1, 'makeUniversal: lstat ppc: '.$!.' for:',

   937                     $filePPC->path());

   938   }

   939   if (defined($fileX86) && !defined($typeX86 = $fileX86->lstatType())) {

   940     return complain(1, 'makeUniversal: lstat x86: '.$!.' for:',

   941                     $fileX86->path());

   942   }

   944   if (defined($filePPC) && defined($fileX86) && $typePPC != $typeX86) {

   945     return complain(1, 'makeUniversal: incompatible types:',

   946                     $filePPC->path(),

   947                     $fileX86->path());

   948   }

   950   # $aSourceFile will contain a FileAttrCache object that will return

   951   # the correct type data.  It's used because it's possible for one of

   952   # the two source files to be undefined (indicating a straight copy).

   953   my ($aSourceFile);

   954   if (defined($filePPC)) {

   955     $aSourceFile = $filePPC;

   956   }

   957   else {

   958     $aSourceFile = $fileX86;

   959   }

   961   if ($aSourceFile->lIsDir()) {

   962     if ($gVerbosity >= 3 || $gDryRun) {

   963       print('mkdir '.(argumentEscape($fileTargetPath))[0]."\n");

   964     }

   965     if (!$gDryRun && !mkdir($fileTargetPath)) {

   966       return complain(1, 'makeUniversal: mkdir: '.$!.' for:',

   967                       $fileTargetPath);

   968     }

   970     my ($rv);

   972     if (!($rv = makeUniversalDirectory($filePPC, $fileX86, $fileTargetPath))) {

   973       # makeUniversalDirectory printed an error.

   974       if ($isToplevel) {

   975         command($gConfig{'cmd_rm'},'-rf','--',$fileTargetPath);

   976       }

   977     }

   978     else {

   979       # Touch the directory when leaving it.  If unify is being run on an

   980       # .app bundle, the .app might show up without an icon because the

   981       # system might have found the .app before it was completely built.

   982       # Touching it dirties it in LaunchServices' mind.

   983       if ($gVerbosity >= 3) {

   984         print('touch '.(argumentEscape($fileTargetPath))[0]."\n");

   985       }

   986       utime(undef, undef, $fileTargetPath);

   987     }

   989     return $rv;

   990   }

   991   elsif ($aSourceFile->lIsSymLink()) {

   992     my ($linkPPC, $linkX86);

   993     if (defined($filePPC) && !defined($linkPPC=readlink($filePPC->path()))) {

   994       return complain(1, 'makeUniversal: readlink ppc: '.$!.' for:',

   995                       $filePPC->path());

   996     }

   997     if (defined($fileX86) && !defined($linkX86=readlink($fileX86->path()))) {

   998       return complain(1, 'makeUniversal: readlink x86: '.$!.' for:',

   999                       $fileX86->path());

  1000     }

  1001     if (defined($filePPC) && defined($fileX86) && $linkPPC ne $linkX86) {

  1002       return complain(1, 'makeUniversal: symbolic links differ:',

  1003                       $filePPC->path(),

  1004                       $fileX86->path());

  1005     }

  1007     # $aLink here serves the same purpose as $aSourceFile in the enclosing

  1008     # block: it refers to the target of the symbolic link, whether there

  1009     # is one valid source or two.

  1010     my ($aLink);

  1011     if (defined($linkPPC)) {

  1012       $aLink = $linkPPC;

  1013     }

  1014     else {

  1015       $aLink = $linkX86;

  1016     }

  1018     if ($gVerbosity >= 3 || $gDryRun) {

  1019       print('ln -s '.

  1020             join(' ',argumentEscape($aLink, $fileTargetPath))."\n");

  1021     }

  1022     if (!$gDryRun && !symlink($aLink, $fileTargetPath)) {

  1023       return complain(1, 'makeUniversal: symlink: '.$!.' for:',

  1024                       $aLink,

  1025                       $fileTargetPath);

  1026     }

  1028     return 1;

  1029   }

  1030   elsif($aSourceFile->lIsRegularFile()) {

  1031     my ($machPPC, $machX86, $fileName);

  1032     if (!defined($filePPC) || !defined($fileX86)) {

  1033       # One of the source files isn't present.  The right thing to do is

  1034       # to just copy what does exist straight over, so skip Mach-O checks.

  1035       $machPPC = 0;

  1036       $machX86 = 0;

  1037       if (defined($filePPC)) {

  1038         $fileName = $filePPC;

  1039       } elsif (defined($fileX86)) {

  1040         $fileName = $fileX86;

  1041       } else {

  1042         complain(1, "The file must exist in at least one directory");

  1043         exit(1);

  1044       }

  1045     }

  1046     else {

  1047       # both files exist, pick the name of one.

  1048       $fileName = $fileX86;

  1049       if (!defined($machPPC=$filePPC->isMachO())) {

  1050         return complain(1, 'makeUniversal: isFileMachO ppc failed for:',

  1051                         $filePPC->path());

  1052       }

  1053       if (!defined($machX86=$fileX86->isMachO())) {

  1054         return complain(1, 'makeUniversal: isFileMachO x86 failed for:',

  1055                         $fileX86->path());

  1056       }

  1057     }

  1059     if ($machPPC != $machX86) {

  1060       return complain(1, 'makeUniversal: variant Mach-O attributes:',

  1061                       $filePPC->path(),

  1062                   $fileX86->path());

  1063     }

  1065     if ($machPPC) {

  1066       # makeUniversalFile will print an error if it fails.

  1067       return makeUniversalFile($filePPC, $fileX86, $fileTargetPath);

  1068     }

  1070     if (grep { $fileName->path() =~ m/$_/; } @gSortMatches) {

  1071       # Regular files, but should be compared with sorting first.

  1072       # copyIfIdenticalWhenSorted will print an error if it fails.

  1073       return copyIfIdenticalWhenSorted($filePPC, $fileX86, $fileTargetPath);

  1074     }

  1076     # Regular file.  copyIfIdentical will print an error if it fails.

  1077     return copyIfIdentical($filePPC, $fileX86, $fileTargetPath);

  1078   }

  1080   # Special file, don't know how to handle.

  1081   return complain(1, 'makeUniversal: cannot handle special file:',

  1082                   $filePPC->path(),

  1083                   $fileX86->path());

  1084 }

  1086 # usage()

  1087 #

  1088 # Give the user a hand.

  1089 sub usage() {

  1090   print STDERR (

  1091 "usage: unify <ppc-path> <x86-path> <universal-path>\n".

  1092 "            [--dry-run]           (print what would be done)\n".

  1093 "            [--only-one <action>] (skip, copy, fail; default=copy)\n".

  1094 "            [--verbosity <level>] (0, 1, 2, 3; default=2)\n");

  1095   return;

  1096 }

  1098 # readZipCRCs($zipFile)

  1099 #

  1100 # $zipFile is the pathname to a zip file whose directory will be read.

  1101 # A reference to a hash is returned, with the member pathnames from the

  1102 # zip file as keys, and reasonably unique identifiers as values.  The

  1103 # format of the values is not specified exactly, but does include the

  1104 # member CRCs and sizes and differentiates between files and directories.

  1105 # It specifically does not distinguish between modification times.  On

  1106 # failure, prints a message and returns undef.

  1107 sub readZipCRCs($) {

  1108   my ($zipFile);

  1109   ($zipFile) = @_;

  1111   my ($ze, $zip);

  1112   $zip = Archive::Zip->new();

  1114   if (($ze = $zip->read($zipFile)) != AZ_OK) {

  1115     complain(1, 'readZipCRCs: read error '.$ze.' for:',

  1116              $zipFile);

  1117     return undef;

  1118   }

  1120   my ($member, %memberCRCs, @memberList);

  1121   %memberCRCs = ();

  1122   @memberList = $zip->members();

  1124   foreach $member (@memberList) {

  1125     # Take a few of the attributes that identify the file and stuff them into

  1126     # the members hash.  Directories will show up with size 0 and crc32 0,

  1127     # so isDirectory() is used to distinguish them from empty files.

  1128     $memberCRCs{$member->fileName()} = join(',', $member->isDirectory() ? 1 : 0,

  1129                                                  $member->uncompressedSize(),

  1130                                                  $member->crc32String());

  1131   }

  1133   return {%memberCRCs};

  1134 }

  1136 {

  1137   # FileAttrCache allows various attributes about a file to be cached

  1138   # so that if they are needed again after first use, no system calls

  1139   # will be made and the program won't need to hit the disk.

  1141   package FileAttrCache;

  1143   # from /usr/include/mach-o/loader.h

  1144   use constant MH_MAGIC    => 0xfeedface;

  1145   use constant MH_CIGAM    => 0xcefaedfe;

  1146   use constant MH_MAGIC_64 => 0xfeedfacf;

  1147   use constant MH_CIGAM_64 => 0xcffaedfe;

  1149   use Fcntl(':DEFAULT', ':mode');

  1151   # FileAttrCache->new($path)

  1152   #

  1153   # Creates a new FileAttrCache object for the file at path $path and

  1154   # returns it.  The cache is not primed at creation time, values are

  1155   # fetched lazily as they are needed.

  1156   sub new($$) {

  1157     my ($class, $path, $proto, $this);

  1158     ($proto, $path) = @_;

  1159     if (!($class = ref($proto))) {

  1160       $class = $proto;

  1161     }

  1162     $this = {

  1163       'path'        => $path,

  1164       'lstat'       => undef,

  1165       'lstatErrno'  => 0,

  1166       'lstatInit'   => 0,

  1167       'magic'       => undef,

  1168       'magic2'       => undef,

  1169       'magicErrno'  => 0,

  1170       'magicErrMsg' => undef,

  1171       'magicInit'   => 0,

  1172       'stat'        => undef,

  1173       'statErrno'   => 0,

  1174       'statInit'    => 0,

  1175     };

  1176     bless($this, $class);

  1177     return($this);

  1178   }

  1180   # $FileAttrCache->isFat()

  1181   #

  1182   # Returns true if the file is a fat Mach-O file, false if it's not, and

  1183   # undef if an error occurs.  See /usr/include/mach-o/fat.h.

  1184   sub isFat($) {

  1185     my ($magic, $magic2, $this);

  1186     ($this) = @_;

  1188     # magic() caches, there's no separate cache because isFat() doesn't hit

  1189     # the disk other than by calling magic().

  1191     if (!defined($magic = $this->magic())) {

  1192       return undef;

  1193     }

  1194     $magic2 = $this->magic2();

  1196     # We have to sanity check the second four bytes, because Java class

  1197     # files use the same magic number as Mach-O fat binaries.

  1198     # This logic is adapted from file(1), which says that Mach-O uses

  1199     # these bytes to count the number of architectures within, while

  1200     # Java uses it for a version number. Conveniently, there are only

  1201     # 18 labelled Mach-O architectures, and Java's first released

  1202     # class format used the version 43.0.

  1203     if ($magic == 0xcafebabe && $magic2 < 20) {

  1204       return 1;

  1205     }

  1207     return 0;

  1208   }

  1210   # $FileAttrCache->isMachO()

  1211   #

  1212   # Returns true if the file is a Mach-O image (including a fat file), false

  1213   # if it's not, and undef if an error occurs.  See

  1214   # /usr/include/mach-o/loader.h and /usr/include/mach-o/fat.h.

  1215   sub isMachO($) {

  1216     my ($magic, $this);

  1217     ($this) = @_;

  1219     # magic() caches, there's no separate cache because isMachO() doesn't hit

  1220     # the disk other than by calling magic().

  1222     if (!defined($magic = $this->magic())) {

  1223       return undef;

  1224     }

  1226     # Accept Mach-O fat files or Mach-O thin files of either endianness.

  1227     if ($magic == MH_MAGIC ||

  1228         $magic == MH_CIGAM ||

  1229         $magic == MH_MAGIC_64 ||

  1230         $magic == MH_CIGAM_64 ||

  1231         $this->isFat()) {

  1232       return 1;

  1233     }

  1235     return 0;

  1236   }

  1238   # $FileAttrCache->isZip()

  1239   #

  1240   # Returns true if the file is a zip file, false if it's not, and undef if

  1241   # an error occurs.  See http://www.pkware.com/business_and_developers/developer/popups/appnote.txt .

  1242   sub isZip($) {

  1243     my ($magic, $this);

  1244     ($this) = @_;

  1246     # magic() caches, there's no separate cache because isFat() doesn't hit

  1247     # the disk other than by calling magic().

  1249     if (!defined($magic = $this->magic())) {

  1250       return undef;

  1251     }

  1253     if ($magic == 0x504b0304) {

  1254       return 1;

  1255     }

  1257     return 0;

  1258   }

  1260   # $FileAttrCache->lIsExecutable()

  1261   #

  1262   # Wraps $FileAttrCache->lstat(), returning true if the file is has any,

  1263   # execute bit set, false if none are set, or undef if an error occurs.

  1264   # On error, $! is set to lstat's errno.

  1265   sub lIsExecutable($) {

  1266     my ($mode, $this);

  1267     ($this) = @_;

  1269     if (!defined($mode = $this->lstatMode())) {

  1270       return undef;

  1271     }

  1273     return $mode & (S_IXUSR | S_IXGRP | S_IXOTH);

  1274   }

  1276   # $FileAttrCache->lIsDir()

  1277   #

  1278   # Wraps $FileAttrCache->lstat(), returning true if the file is a directory,

  1279   # false if it isn't, or undef if an error occurs.  Because lstat is used,

  1280   # this will return false even if the file is a symlink pointing to a

  1281   # directory.  On error, $! is set to lstat's errno.

  1282   sub lIsDir($) {

  1283     my ($type, $this);

  1284     ($this) = @_;

  1286     if (!defined($type = $this->lstatType())) {

  1287       return undef;

  1288     }

  1290     return S_ISDIR($type);

  1291   }

  1293   # $FileAttrCache->lIsRegularFile()

  1294   #

  1295   # Wraps $FileAttrCache->lstat(), returning true if the file is a regular,

  1296   # file, false if it isn't, or undef if an error occurs.  Because lstat is

  1297   # used, this will return false even if the file is a symlink pointing to a

  1298   # regular file.  On error, $! is set to lstat's errno.

  1299   sub lIsRegularFile($) {

  1300     my ($type, $this);

  1301     ($this) = @_;

  1303     if (!defined($type = $this->lstatType())) {

  1304       return undef;

  1305     }

  1307     return S_ISREG($type);

  1308   }

  1310   # $FileAttrCache->lIsSymLink()

  1311   #

  1312   # Wraps $FileAttrCache->lstat(), returning true if the file is a symbolic,

  1313   # link, false if it isn't, or undef if an error occurs.  On error, $! is

  1314   # set to lstat's errno.

  1315   sub lIsSymLink($) {

  1316     my ($type, $this);

  1317     ($this) = @_;

  1319     if (!defined($type = $this->lstatType())) {

  1320       return undef;

  1321     }

  1323     return S_ISLNK($type);

  1324   }

  1326   # $FileAttrCache->lstat()

  1327   #

  1328   # Wraps the lstat system call, providing a cache to speed up multiple

  1329   # lstat calls for the same file.  See lstat(2) and lstat in perlfunc(1).

  1330   sub lstat($) {

  1331     my (@stat, $this);

  1332     ($this) = @_;

  1334     # Use the cached lstat result.

  1335     if ($$this{'lstatInit'}) {

  1336       if (defined($$this{'lstatErrno'})) {

  1337         $! = $$this{'lstatErrno'};

  1338       }

  1339       return @{$$this{'lstat'}};

  1340     }

  1341     $$this{'lstatInit'} = 1;

  1343     if (!(@stat = CORE::lstat($$this{'path'}))) {

  1344       $$this{'lstatErrno'} = $!;

  1345     }

  1347     $$this{'lstat'} = [@stat];

  1348     return @stat;

  1349   }

  1351   # $FileAttrCache->lstatMode()

  1352   #

  1353   # Wraps $FileAttrCache->lstat(), returning the mode bits from the st_mode

  1354   # field, or undef if an error occurs.  On error, $! is set to lstat's

  1355   # errno.

  1356   sub lstatMode($) {

  1357     my (@stat, $this);

  1358     ($this) = @_;

  1360     if (!(@stat = $this->lstat())) {

  1361       return undef;

  1362     }

  1364     return S_IMODE($stat[2]);

  1365   }

  1367   # $FileAttrCache->lstatType()

  1368   #

  1369   # Wraps $FileAttrCache->lstat(), returning the type bits from the st_mode

  1370   # field, or undef if an error occurs.  On error, $! is set to lstat's

  1371   # errno.

  1372   sub lstatType($) {

  1373     my (@stat, $this);

  1374     ($this) = @_;

  1376     if (!(@stat = $this->lstat())) {

  1377       return undef;

  1378     }

  1380     return S_IFMT($stat[2]);

  1381   }

  1383   # $FileAttrCache->magic()

  1384   #

  1385   # Returns the "magic number" for the file by reading its first four bytes

  1386   # as a big-endian unsigned 32-bit integer and returning the result.  If an

  1387   # error occurs, returns undef and prints diagnostic messages to stderr.  If

  1388   # the file is shorter than 32 bits, returns -1.  A cache is provided to

  1389   # speed multiple magic calls for the same file.

  1390   sub magic($) {

  1391     my ($this);

  1392     ($this) = @_;

  1394     # Use the cached magic result.

  1395     if ($$this{'magicInit'}) {

  1396       if (defined($$this{'magicErrno'})) {

  1397         if (defined($$this{'magicErrMsg'})) {

  1398           complain(1, 'FileAttrCache::magic: '.$$this{'magicErrMsg'}.' for:',

  1399                    $$this{'path'});

  1400         }

  1401         $! = $$this{'magicErrno'};

  1402       }

  1403       return $$this{'magic'};

  1404     }

  1406     $$this{'magicInit'} = 1;

  1408     my ($fh);

  1409     if (!sysopen($fh, $$this{'path'}, O_RDONLY)) {

  1410       $$this{'magicErrno'} = $!;

  1411       $$this{'magicErrMsg'} = 'open "'.$$this{'path'}.'": '.$!;

  1412       complain(1, 'FileAttrCache::magic: '.$$this{'magicErrMsg'}.' for:',

  1413                $$this{'path'});

  1414       return undef;

  1415     }

  1417     $! = 0;

  1418     my ($bytes, $magic, $bytes2, $magic2);

  1419     if (!defined($bytes = sysread($fh, $magic, 4))) {

  1420       $$this{'magicErrno'} = $!;

  1421       $$this{'magicErrMsg'} = 'read "'.$$this{'path'}.'": '.$!;

  1422       complain(1, 'FileAttrCache::magic: '.$$this{'magicErrMsg'}.' for:',

  1423                $$this{'path'});

  1424       close($fh);

  1425       return undef;

  1426     }

  1427     else {

  1428       $bytes2 = sysread($fh, $magic2, 4);

  1429     }

  1431     close($fh);

  1433     if ($bytes != 4) {

  1434       # The file is too short, didn't read a magic number.  This isn't really

  1435       # an error.  Return an unlikely value.

  1436       $$this{'magic'} = -1;

  1437       $$this{'magic2'} = -1;

  1438       return -1;

  1439     }

  1440     if ($bytes2 != 4) {

  1441       # File is too short to read a second 4 bytes.

  1442       $magic2 = -1;

  1443     }

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

  1446     $$this{'magic2'} = unpack('N', $magic2);

  1447     return $$this{'magic'};

  1448   }

  1450   # $FileAttrCache->magic2()

  1451   #

  1452   # Returns the second four bytes of the file as a 32-bit little endian number.

  1453   # See magic(), above for more info.

  1454   sub magic2($) {

  1455     my ($this);

  1456     ($this) = @_;

  1458     # we do the actual work (and cache it) in magic().

  1459     if (!$$this{'magicInit'}) {

  1460       my $magic = $$this->magic();

  1461     }

  1463     return $$this{'magic2'};

  1464   }

  1466   # $FileAttrCache->path()

  1467   #

  1468   # Returns the file's pathname.

  1469   sub path($) {

  1470     my ($this);

  1471     ($this) = @_;

  1472     return $$this{'path'};

  1473   }

  1475   # $FileAttrCache->stat()

  1476   #

  1477   # Wraps the stat system call, providing a cache to speed up multiple

  1478   # stat calls for the same file.  If lstat() has already been called and

  1479   # the file is not a symbolic link, the cached lstat() result will be used.

  1480   # See stat(2) and lstat in perlfunc(1).

  1481   sub stat($) {

  1482     my (@stat, $this);

  1483     ($this) = @_;

  1485     # Use the cached stat result.

  1486     if ($$this{'statInit'}) {

  1487       if (defined($$this{'statErrno'})) {

  1488         $! = $$this{'statErrno'};

  1489       }

  1490       return @{$$this{'stat'}};

  1491     }

  1493     $$this{'statInit'} = 1;

  1495     # If lstat has already been called, and the file isn't a symbolic link,

  1496     # use the cached lstat result.

  1497     if ($$this{'lstatInit'} && !$$this{'lstatErrno'} &&

  1498         !S_ISLNK(${$$this{'lstat'}}[2])) {

  1499       $$this{'stat'} = $$this{'lstat'};

  1500       return @{$$this{'stat'}};

  1501     }

  1503     if (!(@stat = CORE::stat($$this{'path'}))) {

  1504       $$this{'statErrno'} = $!;

  1505     }

  1507     $$this{'stat'} = [@stat];

  1508     return @stat;

  1509   }

  1511   # $FileAttrCache->statSize()

  1512   #

  1513   # Wraps $FileAttrCache->stat(), returning the st_size field, or undef

  1514   # undef if an error occurs.  On error, $! is set to stat's errno.

  1515   sub statSize($) {

  1516     my (@stat, $this);

  1517     ($this) = @_;

  1519     if (!(@stat = $this->lstat())) {

  1520       return undef;

  1521     }

  1523     return $stat[7];

  1524   }

  1525 }

The Tor Browser / file revision

build/macosx/universal/unify@b8a032363ba2

build/macosx/universal/unify