← Back to branch summary

~ubuntu-branches/ubuntu/quantal/enigmail/quantal-security

« back to all changes in this revision

Viewing changes to mozilla/build/macosx/universal/unify

  • Committer: Package Import Robot
  • Author(s): Chris Coulson
  • Date: 2013-09-13 16:02:15 UTC
  • mfrom: (0.12.16)
  • Revision ID: package-import@ubuntu.com-20130913160215-u3g8nmwa0pdwagwc
Tags: 2:1.5.2-0ubuntu0.12.10.1
* New upstream release v1.5.2 for Thunderbird 24

* Build enigmail using a stripped down Thunderbird 17 build system, as it's
  now quite difficult to build the way we were doing previously, with the
  latest Firefox build system
* Add debian/patches/no_libxpcom.patch - Don't link against libxpcom, as it
  doesn't exist anymore (but exists in the build system)
* Add debian/patches/use_sdk.patch - Use the SDK version of xpt.py and
  friends
* Drop debian/patches/ipc-pipe_rename.diff (not needed anymore)
* Drop debian/patches/makefile_depth.diff (not needed anymore)

Show diffs side-by-side

added added

removed removed

Lines of Context:
mozilla/build/macosx/universal/unify
 
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/.
 
5
 
 
6
use strict;
 
7
use warnings;
 
8
 
 
9
=pod
 
10
 
 
11
=head1 NAME
 
12
 
 
13
B<unify> - Mac OS X universal binary packager
 
14
 
 
15
=head1 SYNOPSIS
 
16
 
 
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>]
 
25
 
 
26
=head1 DESCRIPTION
 
27
 
 
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."
 
31
 
 
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.
 
38
 
 
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.
 
43
 
 
44
Behavior when one architecture-specific tree contains files that the other
 
45
does not is controlled by the B<--only-one> option.
 
46
 
 
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.
 
52
 
 
53
=head1 OPTIONS
 
54
 
 
55
=over 5
 
56
 
 
57
=item I<ppc-path>
 
58
 
 
59
=item I<x86-path>
 
60
 
 
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.
 
65
 
 
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>.
 
69
 
 
70
=item I<target-path>
 
71
 
 
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>.
 
74
 
 
75
=item B<--dry-run>
 
76
 
 
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.
 
83
 
 
84
=item B<--only-one> I<action>
 
85
 
 
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.
 
91
 
 
92
The default I<action> is copy.
 
93
 
 
94
=item B<--verbosity> I<level>
 
95
 
 
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.
 
103
 
 
104
The default I<level> is 2.
 
105
 
 
106
=item B<--unify-with-sort> I<regex>
 
107
 
 
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.
 
112
 
 
113
=back
 
114
 
 
115
=head1 EXAMPLES
 
116
 
 
117
=over 5
 
118
 
 
119
=item Create a universal .app bundle from two architecture-specific .app
 
120
bundles:
 
121
 
 
122
unify --only-one copy ppc/dist/firefox/Firefox.app
 
123
  x86/dist/firefox/Firefox.app universal/Firefox.app
 
124
  --verbosity 3
 
125
 
 
126
=item Merge two identical architecture-specific trees:
 
127
 
 
128
unify --only-one fail /usr/local /nfs/x86/usr/local
 
129
  /tmp/usrlocal.fat
 
130
 
 
131
=back
 
132
 
 
133
=head1 REQUIREMENTS
 
134
 
 
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.
 
139
 
 
140
=head1 LICENSE
 
141
 
 
142
MPL 1.1/GPL 2.0/LGPL 2.1.  Your choice
 
143
 
 
144
=head1 AUTHOR
 
145
 
 
146
The software was initially written by Mark Mentovai; copyright 2006
 
147
Google Inc.
 
148
 
 
149
=head1 SEE ALSO
 
150
 
 
151
L<cmp(1)>, L<ditto(1)>, L<lipo(1)>
 
152
 
 
153
=cut
 
154
 
 
155
use Archive::Zip(':ERROR_CODES');
 
156
use Errno;
 
157
use Fcntl;
 
158
use File::Compare;
 
159
use File::Copy;
 
160
use Getopt::Long;
 
161
 
 
162
my (%gConfig, $gDryRun, $gOnlyOne, $gVerbosity, @gSortMatches);
 
163
 
 
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($);
 
180
 
 
181
{
 
182
  package FileAttrCache;
 
183
 
 
184
  sub new($$);
 
185
 
 
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
}
 
202
 
 
203
%gConfig = (
 
204
  'cmd_lipo' => 'lipo',
 
205
  'cmd_rm'   => 'rm',
 
206
);
 
207
 
 
208
$gDryRun = 0;
 
209
$gOnlyOne = 'copy';
 
210
$gVerbosity = 2;
 
211
@gSortMatches = ();
 
212
 
 
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()
 
219
 
 
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
}
 
225
 
 
226
if (!makeUniversal($ARGV[0],$ARGV[1],$ARGV[2])) {
 
227
  # makeUniversal or something it called will have printed an error.
 
228
  exit(1);
 
229
}
 
230
 
 
231
exit(0);
 
232
 
 
233
# argumentEscape(@arguments)
 
234
#
 
235
# Takes a list of @arguments and makes them shell-safe.
 
236
sub argumentEscape(@) {
 
237
  my (@arguments);
 
238
  @arguments = @_;
 
239
 
 
240
  my ($argument, @argumentsOut);
 
241
  foreach $argument (@arguments) {
 
242
    $argument =~ s%([^A-Za-z0-9_\-/.=+,])%\\$1%g;
 
243
    push(@argumentsOut, $argument);
 
244
  }
 
245
 
 
246
  return @argumentsOut;
 
247
}
 
248
 
 
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
}
 
267
 
 
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) = @_;
 
283
 
 
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
  }
 
293
 
 
294
  my (@diffCRCs, @onlyInZip1);
 
295
  @diffCRCs = ();
 
296
  @onlyInZip1 = ();
 
297
 
 
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
  }
 
311
 
 
312
  # If any members remain in %CRCHash2, it's because they're not present
 
313
  # in $zip1.
 
314
  my (@onlyInZip2);
 
315
  @onlyInZip2 = keys(%$CRCHash2);
 
316
 
 
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
  }
 
335
 
 
336
  return 1;
 
337
}
 
338
 
 
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) = @_;
 
353
 
 
354
  if ($gVerbosity >= $severity) {
 
355
    print STDERR ($0.': '.$message."\n");
 
356
 
 
357
    my ($item);
 
358
    while ($item = shift(@list)) {
 
359
      print STDERR ('  '.(argumentEscape($item))[0].
 
360
                    (scalar(@list)?',':'')."\n");
 
361
    }
 
362
  }
 
363
 
 
364
  return 0;
 
365
}
 
366
 
 
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) = @_;
 
385
 
 
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
  }
 
393
 
 
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
  }
 
435
 
 
436
  if ($gVerbosity >= 3 || $gDryRun) {
 
437
    print('cp '.
 
438
          join(' ',argumentEscape($source1->path(), $target))."\n");
 
439
  }
 
440
 
 
441
  if (!$gDryRun) {
 
442
    my ($isExecutable);
 
443
 
 
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());
 
448
 
 
449
    if (!createUniqueFile($target, $isExecutable ? 0777 : 0666)) {
 
450
      # createUniqueFile printed an error.
 
451
      return 0;
 
452
    }
 
453
 
 
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
  }
 
462
 
 
463
  return 1;
 
464
}
 
465
 
 
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
}
 
477
 
 
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
}
 
489
 
 
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);
 
501
 
 
502
  return undef if !@lines1 || !@lines2;
 
503
  return 1 unless scalar @lines1 == scalar @lines2;
 
504
 
 
505
  for (my $i = 0; $i < scalar @lines1; $i++) {
 
506
    return 1 if $lines1[$i] ne $lines2[$i];
 
507
  }
 
508
  return 0;
 
509
}
 
510
 
 
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) = @_;
 
522
 
 
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
  }
 
541
 
 
542
  if ($gVerbosity >= 3 || $gDryRun) {
 
543
    print('cp '.
 
544
          join(' ',argumentEscape($source1->path(), $target))."\n");
 
545
  }
 
546
 
 
547
  if (!$gDryRun) {
 
548
    my ($isExecutable);
 
549
 
 
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());
 
554
 
 
555
    if (!createUniqueFile($target, $isExecutable ? 0777 : 0666)) {
 
556
      # createUniqueFile printed an error.
 
557
      return 0;
 
558
    }
 
559
 
 
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
  }
 
569
 
 
570
  return 1;
 
571
}
 
572
 
 
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) = @_;
 
583
 
 
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);
 
590
 
 
591
  return 1;
 
592
}
 
593
 
 
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) = @_;
 
602
 
 
603
  my ($filePPC, $fileX86);
 
604
  $filePPC = FileAttrCache->new($pathPPC);
 
605
  $fileX86 = FileAttrCache->new($pathX86);
 
606
 
 
607
  return makeUniversalInternal(1, $filePPC, $fileX86, $pathTarget);
 
608
}
 
609
 
 
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) = @_;
 
633
 
 
634
  my ($dh, @filesPPC, @filesX86);
 
635
 
 
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
  }
 
645
 
 
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
  }
 
655
 
 
656
  my (%common, $file, %onlyPPC, %onlyX86);
 
657
 
 
658
  %onlyPPC = ();
 
659
  foreach $file (@filesPPC) {
 
660
    if ($file eq '.' || $file eq '..') {
 
661
      next;
 
662
    }
 
663
    $onlyPPC{$file}=1;
 
664
  }
 
665
 
 
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
  }
 
680
 
 
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
  }
 
691
 
 
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
  }
 
705
 
 
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
  }
 
713
 
 
714
  if ($gOnlyOne eq 'fail' && (keys(%onlyPPC) || keys(%onlyX86))) {
 
715
    # Error message(s) printed above.
 
716
    return 0;
 
717
  }
 
718
 
 
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
    }
 
729
 
 
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
  }
 
740
 
 
741
  return 1;
 
742
}
 
743
 
 
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;
 
761
 
 
762
  @tempThinFiles = ();
 
763
 
 
764
  # The source files might already be fat.  They should be thinned out to only
 
765
  # contain a single architecture.
 
766
 
 
767
  my ($isFatPPC, $isFatX86);
 
768
 
 
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
  }
 
784
 
 
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
  }
 
801
 
 
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.
 
812
 
 
813
  my ($sizePPC, $sizeX86, $thinPPCForStat, $thinX86ForStat);
 
814
 
 
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
  }
 
827
 
 
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
  }
 
838
 
 
839
  $sizePPC = $sizePPC % 4096;
 
840
  $sizeX86 = $sizeX86 % 4096;
 
841
 
 
842
  my (@thinFiles);
 
843
 
 
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
  }
 
861
 
 
862
  my ($isExecutable);
 
863
  $isExecutable = $sourcePPC->lIsExecutable() ||
 
864
                  $sourceX86->lIsExecutable();
 
865
 
 
866
  if (!$gDryRun) {
 
867
    # Ensure that the file does not yet exist.
 
868
 
 
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
  }
 
879
 
 
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
  }
 
888
 
 
889
  unlink(@tempThinFiles);
 
890
 
 
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
  }
 
902
 
 
903
  return 1;
 
904
}
 
905
 
 
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) = @_;
 
933
 
 
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
  }
 
943
 
 
944
  if (defined($filePPC) && defined($fileX86) && $typePPC != $typeX86) {
 
945
    return complain(1, 'makeUniversal: incompatible types:',
 
946
                    $filePPC->path(),
 
947
                    $fileX86->path());
 
948
  }
 
949
 
 
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
  }
 
960
 
 
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
    }
 
969
 
 
970
    my ($rv);
 
971
 
 
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
    }
 
988
 
 
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
    }
 
1006
 
 
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
    }
 
1017
 
 
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
    }
 
1027
 
 
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
    }
 
1058
 
 
1059
    if ($machPPC != $machX86) {
 
1060
      return complain(1, 'makeUniversal: variant Mach-O attributes:',
 
1061
                      $filePPC->path(),
 
1062
                  $fileX86->path());
 
1063
    }
 
1064
 
 
1065
    if ($machPPC) {
 
1066
      # makeUniversalFile will print an error if it fails.
 
1067
      return makeUniversalFile($filePPC, $fileX86, $fileTargetPath);
 
1068
    }
 
1069
 
 
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
    }
 
1075
 
 
1076
    # Regular file.  copyIfIdentical will print an error if it fails.
 
1077
    return copyIfIdentical($filePPC, $fileX86, $fileTargetPath);
 
1078
  }
 
1079
 
 
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
}
 
1085
 
 
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
}
 
1097
 
 
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) = @_;
 
1110
 
 
1111
  my ($ze, $zip);
 
1112
  $zip = Archive::Zip->new();
 
1113
 
 
1114
  if (($ze = $zip->read($zipFile)) != AZ_OK) {
 
1115
    complain(1, 'readZipCRCs: read error '.$ze.' for:',
 
1116
             $zipFile);
 
1117
    return undef;
 
1118
  }
 
1119
 
 
1120
  my ($member, %memberCRCs, @memberList);
 
1121
  %memberCRCs = ();
 
1122
  @memberList = $zip->members();
 
1123
 
 
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
  }
 
1132
 
 
1133
  return {%memberCRCs};
 
1134
}
 
1135
 
 
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.
 
1140
 
 
1141
  package FileAttrCache;
 
1142
 
 
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;
 
1148
 
 
1149
  use Fcntl(':DEFAULT', ':mode');
 
1150
 
 
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
  }
 
1179
 
 
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) = @_;
 
1187
 
 
1188
    # magic() caches, there's no separate cache because isFat() doesn't hit
 
1189
    # the disk other than by calling magic().
 
1190
 
 
1191
    if (!defined($magic = $this->magic())) {
 
1192
      return undef;
 
1193
    }
 
1194
    $magic2 = $this->magic2();
 
1195
 
 
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
    }
 
1206
 
 
1207
    return 0;
 
1208
  }
 
1209
 
 
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) = @_;
 
1218
 
 
1219
    # magic() caches, there's no separate cache because isMachO() doesn't hit
 
1220
    # the disk other than by calling magic().
 
1221
 
 
1222
    if (!defined($magic = $this->magic())) {
 
1223
      return undef;
 
1224
    }
 
1225
 
 
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
    }
 
1234
 
 
1235
    return 0;
 
1236
  }
 
1237
 
 
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) = @_;
 
1245
 
 
1246
    # magic() caches, there's no separate cache because isFat() doesn't hit
 
1247
    # the disk other than by calling magic().
 
1248
 
 
1249
    if (!defined($magic = $this->magic())) {
 
1250
      return undef;
 
1251
    }
 
1252
 
 
1253
    if ($magic == 0x504b0304) {
 
1254
      return 1;
 
1255
    }
 
1256
 
 
1257
    return 0;
 
1258
  }
 
1259
 
 
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) = @_;
 
1268
 
 
1269
    if (!defined($mode = $this->lstatMode())) {
 
1270
      return undef;
 
1271
    }
 
1272
 
 
1273
    return $mode & (S_IXUSR | S_IXGRP | S_IXOTH);
 
1274
  }
 
1275
 
 
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) = @_;
 
1285
 
 
1286
    if (!defined($type = $this->lstatType())) {
 
1287
      return undef;
 
1288
    }
 
1289
 
 
1290
    return S_ISDIR($type);
 
1291
  }
 
1292
 
 
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) = @_;
 
1302
 
 
1303
    if (!defined($type = $this->lstatType())) {
 
1304
      return undef;
 
1305
    }
 
1306
 
 
1307
    return S_ISREG($type);
 
1308
  }
 
1309
 
 
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) = @_;
 
1318
   
 
1319
    if (!defined($type = $this->lstatType())) {
 
1320
      return undef;
 
1321
    }
 
1322
 
 
1323
    return S_ISLNK($type);
 
1324
  }
 
1325
 
 
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) = @_;
 
1333
 
 
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;
 
1342
 
 
1343
    if (!(@stat = CORE::lstat($$this{'path'}))) {
 
1344
      $$this{'lstatErrno'} = $!;
 
1345
    }
 
1346
 
 
1347
    $$this{'lstat'} = [@stat];
 
1348
    return @stat;
 
1349
  }
 
1350
 
 
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) = @_;
 
1359
 
 
1360
    if (!(@stat = $this->lstat())) {
 
1361
      return undef;
 
1362
    }
 
1363
 
 
1364
    return S_IMODE($stat[2]);
 
1365
  }
 
1366
 
 
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) = @_;
 
1375
 
 
1376
    if (!(@stat = $this->lstat())) {
 
1377
      return undef;
 
1378
    }
 
1379
 
 
1380
    return S_IFMT($stat[2]);
 
1381
  }
 
1382
 
 
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) = @_;
 
1393
 
 
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
    }
 
1405
 
 
1406
    $$this{'magicInit'} = 1;
 
1407
 
 
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
    }
 
1416
 
 
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
    }
 
1430
 
 
1431
    close($fh);
 
1432
 
 
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
    }
 
1444
 
 
1445
    $$this{'magic'} = unpack('N', $magic);
 
1446
    $$this{'magic2'} = unpack('N', $magic2);
 
1447
    return $$this{'magic'};
 
1448
  }
 
1449
 
 
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) = @_;
 
1457
 
 
1458
    # we do the actual work (and cache it) in magic().
 
1459
    if (!$$this{'magicInit'}) {
 
1460
      my $magic = $$this->magic();
 
1461
    }
 
1462
 
 
1463
    return $$this{'magic2'};
 
1464
  }
 
1465
 
 
1466
  # $FileAttrCache->path()
 
1467
  #
 
1468
  # Returns the file's pathname.
 
1469
  sub path($) {
 
1470
    my ($this);
 
1471
    ($this) = @_;
 
1472
    return $$this{'path'};
 
1473
  }
 
1474
 
 
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) = @_;
 
1484
 
 
1485
    # Use the cached stat result.
 
1486
    if ($$this{'statInit'}) {
 
1487
      if (defined($$this{'statErrno'})) {
 
1488
        $! = $$this{'statErrno'};
 
1489
      }
 
1490
      return @{$$this{'stat'}};
 
1491
    }
 
1492
 
 
1493
    $$this{'statInit'} = 1;
 
1494
 
 
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
    }
 
1502
 
 
1503
    if (!(@stat = CORE::stat($$this{'path'}))) {
 
1504
      $$this{'statErrno'} = $!;
 
1505
    }
 
1506
 
 
1507
    $$this{'stat'} = [@stat];
 
1508
    return @stat;
 
1509
  }
 
1510
 
 
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) = @_;
 
1518
 
 
1519
    if (!(@stat = $this->lstat())) {
 
1520
      return undef;
 
1521
    }
 
1522
 
 
1523
    return $stat[7];
 
1524
  }
 
1525
}