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