← Back to branch summary

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

« back to all changes in this revision

Viewing changes to 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:
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
 
}