The Tor Browser / file comparison

comparison: build/macosx/universal/unify

build/macosx/universal/unify

branch
TOR_BUG_9701
changeset 3
141e0f1194b1
equal deleted inserted replaced
-1:000000000000 0:7881091253f3
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 2.
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 }

Mercurial Repository: The Tor Browser

Europalab SCM Repository Server

mercurial