зеркало из https://github.com/mozilla/pjs.git
1378 строки
42 KiB
Perl
Executable File
1378 строки
42 KiB
Perl
Executable File
#!/usr/bin/perl
|
|
# ***** BEGIN LICENSE BLOCK *****
|
|
# Version: MPL 1.1/GPL 2.0/LGPL 2.1
|
|
#
|
|
# The contents of this file are subject to the Mozilla Public License Version
|
|
# 1.1 (the "License"); you may not use this file except in compliance with
|
|
# the License. You may obtain a copy of the License at
|
|
# http://www.mozilla.org/MPL/
|
|
#
|
|
# Software distributed under the License is distributed on an "AS IS" basis,
|
|
# WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
|
|
# for the specific language governing rights and limitations under the
|
|
# License.
|
|
#
|
|
# The Original Code is the Mozilla Mac OS X Universal Binary Packaging System
|
|
#
|
|
# The Initial Developer of the Original Code is Google Inc.
|
|
# Portions created by the Initial Developer are Copyright (C) 2006
|
|
# the Initial Developer. All Rights Reserved.
|
|
#
|
|
# Contributor(s):
|
|
# Mark Mentovai <mark@moxienet.com> (Original Author)
|
|
#
|
|
# Alternatively, the contents of this file may be used under the terms of
|
|
# either the GNU General Public License Version 2 or later (the "GPL"), or
|
|
# the GNU Lesser General Public License Version 2.1 or later (the "LGPL"),
|
|
# in which case the provisions of the GPL or the LGPL are applicable instead
|
|
# of those above. If you wish to allow use of your version of this file only
|
|
# under the terms of either the GPL or the LGPL, and not to allow others to
|
|
# use your version of this file under the terms of the MPL, indicate your
|
|
# decision by deleting the provisions above and replace them with the notice
|
|
# and other provisions required by the GPL or the LGPL. If you do not delete
|
|
# the provisions above, a recipient may use your version of this file under
|
|
# the terms of any one of the MPL, the GPL or the LGPL.
|
|
#
|
|
# ***** END LICENSE BLOCK *****
|
|
|
|
use strict;
|
|
use warnings;
|
|
|
|
=pod
|
|
|
|
=head1 NAME
|
|
|
|
B<unify> - Mac OS X universal binary packager
|
|
|
|
=head1 SYNOPSIS
|
|
|
|
B<unify>
|
|
I<ppc-path>
|
|
I<x86-path>
|
|
I<universal-path>
|
|
[B<--dry-run>]
|
|
[B<--only-one> I<action>]
|
|
[B<--verbosity> I<level>]
|
|
|
|
=head1 DESCRIPTION
|
|
|
|
I<unify> merges any two architecture-specific files or directory trees
|
|
into a single file or tree suitable for use on either architecture as a
|
|
"fat" or "universal binary."
|
|
|
|
Architecture-specific Mach-O files will be merged into fat Mach-O files
|
|
using L<lipo(1)>. Non-Mach-O files in the architecture-specific trees
|
|
are compared to ensure that they are equivalent before copying. Symbolic
|
|
links are permitted in the architecture-specific trees and will cause
|
|
identical links to be created in the merged tree, provided that the source
|
|
links have identical targets. Directories are processed recursively.
|
|
|
|
If the architecture-specific source trees contain zip archives (including
|
|
jar files) that are not identical according to a byte-for-byte check, they
|
|
are still assumed to be equivalent if both archives contain exactly the
|
|
same members with identical checksums and sizes.
|
|
|
|
Behavior when one architecture-specific tree contains files that the other
|
|
does not is controlled by the B<--only-one> option.
|
|
|
|
If Mach-O files cannot be merged using L<lipo(1)>, zip archives are not
|
|
equivalent, regular files are not identical, or any other error occurs,
|
|
B<unify> will fail with an exit status of 1. Diagnostic messages are
|
|
typically printed to stderr; this behavior can be controlled with the
|
|
B<--verbosity> option.
|
|
|
|
=head1 OPTIONS
|
|
|
|
=over 5
|
|
|
|
=item I<ppc-path>
|
|
|
|
=item I<x86-path>
|
|
|
|
The paths to directory trees containing PowerPC and x86 builds,
|
|
respectively. I<ppc-path> and I<x86-path> are permitted to contain files
|
|
that are already "fat," and only the appropriate architecture's images will
|
|
be used.
|
|
|
|
I<ppc-path> and I<x86-path> are also permitted to both be files, in which
|
|
case B<unify> operates solely on those files, and produces an appropriate
|
|
merged file at I<target-path>.
|
|
|
|
=item I<target-path>
|
|
|
|
The path to the merged file or directory tree. This path will be created,
|
|
and it must not exist prior to running B<unify>.
|
|
|
|
=item B<--dry-run>
|
|
|
|
When specified, the commands that would be executed are printed, without
|
|
actually executing them. Note that B<--dry-run> and the equivalent
|
|
B<--verbosity> level during "wet" runs may print equivalent commands when
|
|
no commands are in fact executed: certain operations are handled internally
|
|
within B<unify>, and an approximation of a command that performs a similar
|
|
task is printed.
|
|
|
|
=item B<--only-one> I<action>
|
|
|
|
Controls handling of files that are only present in one of the two source
|
|
trees. I<action> may be:
|
|
skip - These files are skipped.
|
|
copy - These files are copied from the tree in which they exist.
|
|
fail - When this condition occurs, it is treated as an error.
|
|
|
|
The default I<action> is copy.
|
|
|
|
=item B<--verbosity> I<level>
|
|
|
|
Adjusts the level of loudness of B<unify>. The possible values for
|
|
I<level> are:
|
|
0 - B<unify> never prints anything.
|
|
(Other programs that B<unify> calls may still print messages.)
|
|
1 - Fatal error messages are printed to stderr.
|
|
2 - Nonfatal warnings are printed to stderr.
|
|
3 - Commands are printed to stdout as they are executed.
|
|
|
|
The default I<level> is 2.
|
|
|
|
=back
|
|
|
|
=head1 EXAMPLES
|
|
|
|
=over 5
|
|
|
|
=item Create a universal .app bundle from two architecture-specific .app
|
|
bundles:
|
|
|
|
unify --only-one copy ppc/dist/firefox/Firefox.app
|
|
x86/dist/firefox/Firefox.app universal/Firefox.app
|
|
--verbosity 3
|
|
|
|
=item Merge two identical architecture-specific trees:
|
|
|
|
unify --only-one fail /usr/local /nfs/x86/usr/local
|
|
/tmp/usrlocal.fat
|
|
|
|
=back
|
|
|
|
=head1 REQUIREMENTS
|
|
|
|
The only esoteric requirement of B<unify> is that the L<lipo(1)> command
|
|
be available. It is present on Mac OS X systems at least as early as
|
|
10.3.9, and probably earlier. Mac OS X 10.4 ("Tiger") or later are
|
|
recommended.
|
|
|
|
=head1 LICENSE
|
|
|
|
MPL 1.1/GPL 2.0/LGPL 2.1. Your choice
|
|
|
|
=head1 AUTHOR
|
|
|
|
The software was initially written by Mark Mentovai; copyright 2006
|
|
Google Inc.
|
|
|
|
=head1 SEE ALSO
|
|
|
|
L<cmp(1)>, L<ditto(1)>, L<lipo(1)>
|
|
|
|
=cut
|
|
|
|
use Archive::Zip(':ERROR_CODES');
|
|
use Errno;
|
|
use Fcntl;
|
|
use File::Compare;
|
|
use File::Copy;
|
|
use Getopt::Long;
|
|
|
|
my (%gConfig, $gDryRun, $gOnlyOne, $gVerbosity);
|
|
|
|
sub argumentEscape(@);
|
|
sub command(@);
|
|
sub compareZipArchives($$);
|
|
sub complain($$@);
|
|
sub copyIfIdentical($$$);
|
|
sub createUniqueFile($$);
|
|
sub makeUniversal($$$);
|
|
sub makeUniversalDirectory($$$);
|
|
sub makeUniversalInternal($$$$);
|
|
sub makeUniversalFile($$$);
|
|
sub usage();
|
|
sub readZipCRCs($);
|
|
|
|
{
|
|
package FileAttrCache;
|
|
|
|
sub new($$);
|
|
|
|
sub isFat($);
|
|
sub isMachO($);
|
|
sub isZip($);
|
|
sub lIsDir($);
|
|
sub lIsExecutable($);
|
|
sub lIsRegularFile($);
|
|
sub lIsSymLink($);
|
|
sub lstat($);
|
|
sub lstatMode($);
|
|
sub lstatType($);
|
|
sub magic($);
|
|
sub path($);
|
|
sub stat($);
|
|
sub statSize($);
|
|
}
|
|
|
|
%gConfig = (
|
|
'cmd_lipo' => 'lipo',
|
|
'cmd_rm' => 'rm',
|
|
);
|
|
|
|
$gDryRun = 0;
|
|
$gOnlyOne = 'copy';
|
|
$gVerbosity = 2;
|
|
|
|
Getopt::Long::Configure('pass_through');
|
|
GetOptions('dry-run' => \$gDryRun,
|
|
'only-one=s' => \$gOnlyOne,
|
|
'verbosity=i' => \$gVerbosity,
|
|
'config=s' => \%gConfig); # "hidden" option not in usage()
|
|
|
|
if (scalar(@ARGV) != 3 || $gVerbosity < 0 || $gVerbosity > 3 ||
|
|
($gOnlyOne ne 'skip' && $gOnlyOne ne 'copy' && $gOnlyOne ne 'fail')) {
|
|
usage();
|
|
exit(1);
|
|
}
|
|
|
|
if (!makeUniversal($ARGV[0],$ARGV[1],$ARGV[2])) {
|
|
# makeUniversal or something it called will have printed an error.
|
|
exit(1);
|
|
}
|
|
|
|
exit(0);
|
|
|
|
# argumentEscape(@arguments)
|
|
#
|
|
# Takes a list of @arguments and makes them shell-safe.
|
|
sub argumentEscape(@) {
|
|
my (@arguments);
|
|
@arguments = @_;
|
|
|
|
my ($argument, @argumentsOut);
|
|
foreach $argument (@arguments) {
|
|
$argument =~ s%([^A-Za-z0-9_\-/.=+,])%\\$1%g;
|
|
push(@argumentsOut, $argument);
|
|
}
|
|
|
|
return @argumentsOut;
|
|
}
|
|
|
|
# command(@arguments)
|
|
#
|
|
# Runs the specified command by calling system(@arguments). If $gDryRun
|
|
# is true, the command is printed but not executed, and 0 is returned.
|
|
# if $gVerbosity is greater than 1, the command is printed before being
|
|
# executed. When the command is executed, the system() return value will
|
|
# be returned. stdout and stderr are left connected for command output.
|
|
sub command(@) {
|
|
my (@arguments);
|
|
@arguments = @_;
|
|
if ($gVerbosity >= 3 || $gDryRun) {
|
|
print(join(' ', argumentEscape(@arguments))."\n");
|
|
}
|
|
if ($gDryRun) {
|
|
return 0;
|
|
}
|
|
return system(@arguments);
|
|
}
|
|
|
|
# compareZipArchives($zip1, $zip2)
|
|
#
|
|
# Given two pathnames to zip archives, determines whether or not they are
|
|
# functionally identical. Returns true if they are, false if they differ in
|
|
# some substantial way, and undef if an error occurs. If the zip files
|
|
# differ, diagnostic messages are printed indicating how they differ.
|
|
#
|
|
# Zip files will differ if any of the members are different as defined by
|
|
# readZipCRCs, which consider CRCs, sizes, and file types as stored in the
|
|
# file header. Timestamps are not considered. Zip files also differ if one
|
|
# file contains members that the other one does not. $gOnlyOne has no
|
|
# effect on this behavior.
|
|
sub compareZipArchives($$) {
|
|
my ($zip1, $zip2);
|
|
($zip1, $zip2) = @_;
|
|
|
|
my ($CRCHash1, $CRCHash2);
|
|
if (!defined($CRCHash1 = readZipCRCs($zip1))) {
|
|
# readZipCRCs printed an error.
|
|
return undef;
|
|
}
|
|
if (!defined($CRCHash2 = readZipCRCs($zip2))) {
|
|
# readZipCRCs printed an error.
|
|
return undef;
|
|
}
|
|
|
|
my (@diffCRCs, @onlyInZip1);
|
|
@diffCRCs = ();
|
|
@onlyInZip1 = ();
|
|
|
|
my ($memberName);
|
|
foreach $memberName (keys(%$CRCHash1)) {
|
|
if (!exists($$CRCHash2{$memberName})) {
|
|
# The member is present in $zip1 but not $zip2.
|
|
push(@onlyInZip1, $memberName);
|
|
}
|
|
elsif ($$CRCHash1{$memberName} ne $$CRCHash2{$memberName}) {
|
|
# The member is present in both archives but its CRC or some other
|
|
# other critical attribute isn't identical.
|
|
push(@diffCRCs, $memberName);
|
|
}
|
|
delete($$CRCHash2{$memberName});
|
|
}
|
|
|
|
# If any members remain in %CRCHash2, it's because they're not present
|
|
# in $zip1.
|
|
my (@onlyInZip2);
|
|
@onlyInZip2 = keys(%$CRCHash2);
|
|
|
|
if (scalar(@onlyInZip1) + scalar(@onlyInZip2) + scalar(@diffCRCs)) {
|
|
complain(1, 'compareZipArchives: zip archives differ:',
|
|
$zip1,
|
|
$zip2);
|
|
if (scalar(@onlyInZip1)) {
|
|
complain(1, 'compareZipArchives: members only in former:',
|
|
@onlyInZip1);
|
|
}
|
|
if (scalar(@onlyInZip2)) {
|
|
complain(1, 'compareZipArchives: members only in latter:',
|
|
@onlyInZip2);
|
|
}
|
|
if (scalar(@diffCRCs)) {
|
|
complain(1, 'compareZipArchives: members differ:',
|
|
@diffCRCs);
|
|
}
|
|
return 0;
|
|
}
|
|
|
|
return 1;
|
|
}
|
|
|
|
# complain($severity, $message, @list)
|
|
#
|
|
# Prints $message to stderr if $gVerbosity allows it for severity level
|
|
# $severity. @list is a list of words that will be shell-escaped and printed
|
|
# after $message, one per line, intended to be used, for example, to list
|
|
# arguments to a call that failed.
|
|
#
|
|
# Expected severity levels are 1 for hard errors and 2 for non-fatal warnings.
|
|
#
|
|
# Always returns false as a convenience, so callers can return complain's
|
|
# return value when it is used to signal errors.
|
|
sub complain($$@) {
|
|
my ($severity, $message, @list);
|
|
($severity, $message, @list) = @_;
|
|
|
|
if ($gVerbosity >= $severity) {
|
|
print STDERR ($0.': '.$message."\n");
|
|
|
|
my ($item);
|
|
while ($item = shift(@list)) {
|
|
print STDERR (' '.(argumentEscape($item))[0].
|
|
(scalar(@list)?',':'')."\n");
|
|
}
|
|
}
|
|
|
|
return 0;
|
|
}
|
|
|
|
# copyIfIdentical($source1, $source2, $target)
|
|
#
|
|
# $source1 and $source2 are FileAttrCache objects that are compared, and if
|
|
# identical, copied to path string $target. The comparison is initially
|
|
# done as a byte-for-byte comparison, but if the files differ and appear to
|
|
# be zip archives, compareZipArchives is called to determine whether
|
|
# files that are not byte-for-byte identical are equivalent archives.
|
|
#
|
|
# Returns true on success, false for files that are not identical or
|
|
# equivalent archives, and undef if an error occurs.
|
|
#
|
|
# One of $source1 and $source2 is permitted to be undef. In this event,
|
|
# whichever source is defined is copied directly to $target without performing
|
|
# any comparisons. This enables the $gOnlyOne = 'copy' mode, which is
|
|
# driven by makeUniversalDirectory and makeUniversalInternal.
|
|
sub copyIfIdentical($$$) {
|
|
my ($source1, $source2, $target);
|
|
($source1, $source2, $target) = @_;
|
|
|
|
if (!defined($source1)) {
|
|
# If there's only one source file, make it the first file. Order
|
|
# isn't important here, and this makes it possible to use
|
|
# defined($source2) as the switch, and to always copy from $source1.
|
|
$source1 = $source2;
|
|
$source2 = undef;
|
|
}
|
|
|
|
if (defined($source2)) {
|
|
# Only do the comparisons if there are two source files. If there's
|
|
# only one source file, skip the comparisons and go straight to the
|
|
# copy operation.
|
|
if ($gVerbosity >= 3 || $gDryRun) {
|
|
print('cmp -s '.
|
|
join(' ',argumentEscape($source1->path(), $source2->path()))."\n");
|
|
}
|
|
my ($comparison);
|
|
if (!defined($comparison = compare($source1->path(), $source2->path())) ||
|
|
$comparison == -1) {
|
|
return complain(1, 'copyIfIdentical: compare: '.$!.' while comparing:',
|
|
$source1->path(),
|
|
$source2->path());
|
|
}
|
|
elsif ($comparison != 0) {
|
|
my ($zip1, $zip2);
|
|
if (defined($zip1 = $source1->isZip()) &&
|
|
defined($zip2 = $source2->isZip()) &&
|
|
$zip1 && $zip2) {
|
|
my ($zipComparison);
|
|
if (!defined($zipComparison = compareZipArchives($source1->path(),
|
|
$source2->path)) ||
|
|
!$zipComparison) {
|
|
# An error occurred or the zip files aren't sufficiently identical.
|
|
# compareZipArchives will have printed an error message.
|
|
return 0;
|
|
}
|
|
# The zip files were compared successfully, and they both contain
|
|
# all of the same members, and all of their members' CRCs are
|
|
# identical. For the purposes of this script, the zip files can be
|
|
# treated as identical, so reset $comparison.
|
|
$comparison = 0;
|
|
}
|
|
}
|
|
if ($comparison != 0) {
|
|
return complain(1, 'copyIfIdentical: files differ:',
|
|
$source1->path(),
|
|
$source2->path());
|
|
}
|
|
}
|
|
|
|
if ($gVerbosity >= 3 || $gDryRun) {
|
|
print('cp '.
|
|
join(' ',argumentEscape($source1->path(), $target))."\n");
|
|
}
|
|
|
|
if (!$gDryRun) {
|
|
my ($isExecutable);
|
|
|
|
# Set the execute bits (as allowed by the umask) on the new file if any
|
|
# execute bit is set on either old file.
|
|
$isExecutable = $source1->lIsExecutable() ||
|
|
(defined($source2) && $source2->lIsExecutable());
|
|
|
|
if (!createUniqueFile($target, $isExecutable ? 0777 : 0666)) {
|
|
# createUniqueFile printed an error.
|
|
return 0;
|
|
}
|
|
|
|
if (!copy($source1->path(), $target)) {
|
|
complain(1, 'copyIfIdentical: copy: '.$!.' while copying',
|
|
$source1->path(),
|
|
$target);
|
|
unlink($target);
|
|
return 0;
|
|
}
|
|
}
|
|
|
|
return 1;
|
|
}
|
|
|
|
# createUniqueFile($path, $mode)
|
|
#
|
|
# Creates a new plain empty file at pathname $path, provided it does not
|
|
# yet exist. $mode is used as the file mode. The actual file's mode will
|
|
# be modified by the effective umask. Returns false if the file could
|
|
# not be created, setting $! to the error. An error message is printed
|
|
# in the event of failure.
|
|
sub createUniqueFile($$) {
|
|
my ($path, $mode);
|
|
($path, $mode) = @_;
|
|
|
|
my ($fh);
|
|
if (!sysopen($fh, $path, O_WRONLY | O_CREAT | O_EXCL, $mode)) {
|
|
return complain(1, 'createUniqueFile: open: '.$!.' for:',
|
|
$path);
|
|
}
|
|
close($fh);
|
|
|
|
return 1;
|
|
}
|
|
|
|
# makeUniversal($pathPPC, $pathX86, $pathTarget)
|
|
#
|
|
# The top-level call. $pathPPC, $pathX86, and $pathTarget are strings
|
|
# identifying the ppc and x86 files or directories to merge and the location
|
|
# to merge them to. Returns false on failure and true on success.
|
|
sub makeUniversal($$$) {
|
|
my ($pathTarget, $pathPPC, $pathX86);
|
|
($pathPPC, $pathX86, $pathTarget) = @_;
|
|
|
|
my ($filePPC, $fileX86);
|
|
$filePPC = FileAttrCache->new($pathPPC);
|
|
$fileX86 = FileAttrCache->new($pathX86);
|
|
|
|
return makeUniversalInternal(1, $filePPC, $fileX86, $pathTarget);
|
|
}
|
|
|
|
# makeUniversalDirectory($dirPPC, $dirX86, $dirTarget)
|
|
#
|
|
# This is part of the heart of recursion. $dirPPC and $dirX86 are
|
|
# FileAttrCache objects designating the source ppc and x86 directories to
|
|
# merge into a universal directory at $dirTarget, a string. For each file
|
|
# in $dirPPC and $dirX86, makeUniversalInternal is called.
|
|
# makeUniversalInternal will call back into makeUniversalDirectory for
|
|
# directories, thus completing the recursion. If a failure is encountered
|
|
# in ths function or in makeUniversalInternal or anything that it calls,
|
|
# false is returned, otherwise, true is returned.
|
|
#
|
|
# If there are files present in one source directory but not both, the
|
|
# value of $gOnlyOne controls the behavior. If $gOnlyOne is 'copy', the
|
|
# single source file is copied into $pathTarget. If it is 'skip', it is
|
|
# skipped. If it is 'fail', such files will trigger makeUniversalDirectory
|
|
# to fail.
|
|
#
|
|
# If either source directory is undef, it is treated as having no files.
|
|
# This facilitates deep recursion when entire directories are only present
|
|
# in one source when $gOnlyOne = 'copy'.
|
|
sub makeUniversalDirectory($$$) {
|
|
my ($dirPPC, $dirX86, $dirTarget);
|
|
($dirPPC, $dirX86, $dirTarget) = @_;
|
|
|
|
my ($dh, @filesPPC, @filesX86);
|
|
|
|
@filesPPC = ();
|
|
if (defined($dirPPC)) {
|
|
if (!opendir($dh, $dirPPC->path())) {
|
|
return complain(1, 'makeUniversalDirectory: opendir ppc: '.$!.' for:',
|
|
$dirPPC->path());
|
|
}
|
|
@filesPPC = readdir($dh);
|
|
closedir($dh);
|
|
}
|
|
|
|
@filesX86 = ();
|
|
if (defined($dirX86)) {
|
|
if (!opendir($dh, $dirX86->path())) {
|
|
return complain(1, 'makeUniversalDirectory: opendir x86: '.$!.' for:',
|
|
$dirX86->path());
|
|
}
|
|
@filesX86 = readdir($dh);
|
|
closedir($dh);
|
|
}
|
|
|
|
my (%common, $file, %onlyPPC, %onlyX86);
|
|
|
|
%onlyPPC = ();
|
|
foreach $file (@filesPPC) {
|
|
if ($file eq '.' || $file eq '..') {
|
|
next;
|
|
}
|
|
$onlyPPC{$file}=1;
|
|
}
|
|
|
|
%common = ();
|
|
%onlyX86 = ();
|
|
foreach $file (@filesX86) {
|
|
if ($file eq '.' || $file eq '..') {
|
|
next;
|
|
}
|
|
if ($onlyPPC{$file}) {
|
|
delete $onlyPPC{$file};
|
|
$common{$file}=1;
|
|
}
|
|
else {
|
|
$onlyX86{$file}=1;
|
|
}
|
|
}
|
|
|
|
# First, handle files common to both.
|
|
foreach $file (sort(keys(%common))) {
|
|
if (!makeUniversalInternal(0,
|
|
FileAttrCache->new($dirPPC->path().'/'.$file),
|
|
FileAttrCache->new($dirX86->path().'/'.$file),
|
|
$dirTarget.'/'.$file)) {
|
|
# makeUniversalInternal will have printed an error.
|
|
return 0;
|
|
}
|
|
}
|
|
|
|
# Handle files found only in a single directory here. There are three
|
|
# options, dictated by $gOnlyOne: fail if files are only present in
|
|
# one directory, skip any files only present in one directory, or copy
|
|
# these files straight over to the target directory. In any event,
|
|
# a message will be printed indicating that the file trees don't match
|
|
# exactly.
|
|
if (keys(%onlyPPC)) {
|
|
complain(($gOnlyOne eq 'fail' ? 1 : 2),
|
|
($gOnlyOne ne 'fail' ? 'warning: ' : '').
|
|
'makeUniversalDirectory: only in ppc '.
|
|
(argumentEscape($dirPPC->path()))[0].':',
|
|
argumentEscape(keys(%onlyPPC)));
|
|
}
|
|
|
|
if (keys(%onlyX86)) {
|
|
complain(($gOnlyOne eq 'fail' ? 1 : 2),
|
|
($gOnlyOne ne 'fail' ? 'warning: ' : '').
|
|
'makeUniversalDirectory: only in x86 '.
|
|
(argumentEscape($dirX86->path()))[0].':',
|
|
argumentEscape(keys(%onlyX86)));
|
|
}
|
|
|
|
if ($gOnlyOne eq 'fail' && (keys(%onlyPPC) || keys(%onlyX86))) {
|
|
# Error message(s) printed above.
|
|
return 0;
|
|
}
|
|
|
|
if ($gOnlyOne eq 'copy') {
|
|
foreach $file (sort(keys(%onlyPPC))) {
|
|
if (!makeUniversalInternal(0,
|
|
FileAttrCache->new($dirPPC->path().'/'.$file),
|
|
undef,
|
|
$dirTarget.'/'.$file)) {
|
|
# makeUniversalInternal will have printed an error.
|
|
return 0;
|
|
}
|
|
}
|
|
|
|
foreach $file (sort(keys(%onlyX86))) {
|
|
if (!makeUniversalInternal(0,
|
|
undef,
|
|
FileAttrCache->new($dirX86->path().'/'.$file),
|
|
$dirTarget.'/'.$file)) {
|
|
# makeUniversalInternal will have printed an error.
|
|
return 0;
|
|
}
|
|
}
|
|
}
|
|
|
|
return 1;
|
|
}
|
|
|
|
# makeUniversalFile($sourcePPC, $sourceX86, $targetPath)
|
|
#
|
|
# Creates a universal file at pathname $targetPath based on a ppc image at
|
|
# $sourcePPC and an x86 image at $sourceX86. $sourcePPC and $sourceX86 are
|
|
# both FileAttrCache objects. Returns true on success and false on failure.
|
|
# On failure, diagnostics will be printed to stderr.
|
|
#
|
|
# The source files may be either thin Mach-O images of the appropriate
|
|
# architecture, or fat Mach-O files that contain images of the appropriate
|
|
# architecture.
|
|
#
|
|
# This function wraps the lipo utility, see lipo(1).
|
|
sub makeUniversalFile($$$) {
|
|
my ($sourcePPC, $sourceX86, $targetPath, @tempThinFiles, $thinPPC, $thinX86);
|
|
($sourcePPC, $sourceX86, $targetPath) = @_;
|
|
$thinPPC = $sourcePPC;
|
|
$thinX86 = $sourceX86;
|
|
|
|
@tempThinFiles = ();
|
|
|
|
# The source files might already be fat. They should be thinned out to only
|
|
# contain a single architecture.
|
|
|
|
my ($isFatPPC, $isFatX86);
|
|
|
|
if(!defined($isFatPPC = $sourcePPC->isFat())) {
|
|
# isFat printed its own error
|
|
return 0;
|
|
}
|
|
elsif($isFatPPC) {
|
|
$thinPPC = FileAttrCache->new($targetPath.'.ppc');
|
|
push(@tempThinFiles, $thinPPC->path());
|
|
if (command($gConfig{'cmd_lipo'}, '-thin', 'ppc',
|
|
$sourcePPC->path(), '-output', $thinPPC->path()) != 0) {
|
|
unlink(@tempThinFiles);
|
|
return complain(1, 'lipo thin ppc failed for:',
|
|
$sourcePPC->path(),
|
|
$thinPPC->path());
|
|
}
|
|
}
|
|
|
|
if(!defined($isFatX86 = $sourceX86->isFat())) {
|
|
# isFat printed its own error
|
|
unlink(@tempThinFiles);
|
|
return 0;
|
|
}
|
|
elsif($isFatX86) {
|
|
$thinX86 = FileAttrCache->new($targetPath.'.x86');
|
|
push(@tempThinFiles, $thinX86->path());
|
|
if (command($gConfig{'cmd_lipo'}, '-thin', 'i386',
|
|
$sourceX86->path(), '-output', $thinX86->path()) != 0) {
|
|
unlink(@tempThinFiles);
|
|
return complain(1, 'lipo thin x86 failed for:',
|
|
$sourceX86->path(),
|
|
$thinX86->path());
|
|
}
|
|
}
|
|
|
|
# The image for each architecture in the fat file will be aligned on
|
|
# a specific boundary, default 4096 bytes, see lipo(1) -segalign.
|
|
# Since there's no tail-padding, the fat file will consume the least
|
|
# space on disk if the image that comes last exceeds the segment size
|
|
# by the smallest amount.
|
|
#
|
|
# This saves an average of 1kB per fat file over the naive approach of
|
|
# always putting one architecture first: average savings is 2kB per
|
|
# file, but the naive approach would have gotten it right half of the
|
|
# time.
|
|
|
|
my ($sizePPC, $sizeX86, $thinPPCForStat, $thinX86ForStat);
|
|
|
|
if (!$gDryRun) {
|
|
$thinPPCForStat = $thinPPC;
|
|
$thinX86ForStat = $thinX86;
|
|
}
|
|
else {
|
|
# Normally, fat source files will have been converted into temporary
|
|
# thin files. During a dry run, that doesn't happen, so fake it up
|
|
# a little bit by always using the source file, fat or thin, for the
|
|
# stat.
|
|
$thinPPCForStat = $sourcePPC;
|
|
$thinX86ForStat = $sourceX86;
|
|
}
|
|
|
|
if (!defined($sizePPC = $thinPPCForStat->statSize())) {
|
|
unlink(@tempThinFiles);
|
|
return complain(1, 'stat ppc: '.$!.' for:',
|
|
$thinPPCForStat->path());
|
|
}
|
|
if (!defined($sizeX86 = $thinX86ForStat->statSize())) {
|
|
unlink(@tempThinFiles);
|
|
return complain(1, 'stat x86: '.$!.' for:',
|
|
$thinX86ForStat->path());
|
|
}
|
|
|
|
$sizePPC = $sizePPC % 4096;
|
|
$sizeX86 = $sizeX86 % 4096;
|
|
|
|
my (@thinFiles);
|
|
|
|
if ($sizePPC == 0) {
|
|
# PPC image ends on an alignment boundary, there will be no padding before
|
|
# starting the x86 image.
|
|
@thinFiles = ($thinPPC->path(), $thinX86->path());
|
|
}
|
|
elsif ($sizeX86 == 0 || $sizeX86 > $sizePPC) {
|
|
# x86 image ends on an alignment boundary, there will be no padding before
|
|
# starting the PPC image, or the x86 image exceeds its alignment boundary
|
|
# by more than the PPC image, so there will be less padding if the x86
|
|
# comes first.
|
|
@thinFiles = ($thinX86->path(), $thinPPC->path());
|
|
}
|
|
else {
|
|
# PPC image exceeds its alignment boundary by more than the x86 image, so
|
|
# there will be less padding if the PPC comes first.
|
|
@thinFiles = ($thinPPC->path(), $thinX86->path());
|
|
}
|
|
|
|
my ($isExecutable);
|
|
$isExecutable = $sourcePPC->lIsExecutable() ||
|
|
$sourceX86->lIsExecutable();
|
|
|
|
if (!$gDryRun) {
|
|
# Ensure that the file does not yet exist.
|
|
|
|
# Set the execute bits (as allowed by the umask) on the new file if any
|
|
# execute bit is set on either old file. Yes, it is possible to have
|
|
# proper Mach-O files without x-bits: think object files (.o) and static
|
|
# archives (.a).
|
|
if (!createUniqueFile($targetPath, $isExecutable ? 0777 : 0666)) {
|
|
# createUniqueFile printed an error.
|
|
unlink(@tempThinFiles);
|
|
return 0;
|
|
}
|
|
}
|
|
|
|
# Create the fat file.
|
|
if (command($gConfig{'cmd_lipo'}, '-create', @thinFiles,
|
|
'-output', $targetPath) != 0) {
|
|
unlink(@tempThinFiles, $targetPath);
|
|
return complain(1, 'lipo create fat failed for:',
|
|
@thinFiles,
|
|
$targetPath);
|
|
}
|
|
|
|
unlink(@tempThinFiles);
|
|
|
|
if (!$gDryRun) {
|
|
# lipo seems to think that it's free to set its own file modes that
|
|
# ignore the umask, which is bogus when the rest of this script
|
|
# respects the umask.
|
|
if (!chmod(($isExecutable ? 0777 : 0666) & ~umask(), $targetPath)) {
|
|
complain(1, 'makeUniversalFile: chmod: '.$!.' for',
|
|
$targetPath);
|
|
unlink($targetPath);
|
|
return 0;
|
|
}
|
|
}
|
|
|
|
return 1;
|
|
}
|
|
|
|
# makeUniversalInternal($isToplevel, $filePPC, $fileX86, $fileTargetPath)
|
|
#
|
|
# Given FileAttrCache objects $filePPC and $fileX86, compares filetypes
|
|
# and performs the appropriate action to produce a universal file at
|
|
# path string $fileTargetPath. $isToplevel should be true if this is
|
|
# the recursive base and false otherwise; this controls cleanup behavior
|
|
# (cleanup is only performed at the base, because cleanup itself is
|
|
# recursive).
|
|
#
|
|
# This handles regular files by determining whether they are Mach-O files
|
|
# and calling makeUniversalFile if so and copyIfIdentical otherwise. Symbolic
|
|
# links are handled directly in this function by ensuring that the source link
|
|
# targets are identical and creating a new link with the same target
|
|
# at $fileTargetPath. Directories are handled by calling
|
|
# makeUniversalDirectory.
|
|
#
|
|
# One of $filePPC and $fileX86 is permitted to be undef. In that case,
|
|
# the defined source file is copied directly to the target if a regular
|
|
# file, and symlinked appropriately if a symbolic link. This facilitates
|
|
# use of $gOnlyOne = 'copy', although no $gOnlyOne checks are made in this
|
|
# function, they are all handled in makeUniversalDirectory.
|
|
#
|
|
# Returns true on success. Returns false on failure, including failures
|
|
# in other functions called.
|
|
sub makeUniversalInternal($$$$) {
|
|
my ($filePPC, $fileTargetPath, $fileX86, $isToplevel);
|
|
($isToplevel, $filePPC, $fileX86, $fileTargetPath) = @_;
|
|
|
|
my ($typePPC, $typeX86);
|
|
if (defined($filePPC) && !defined($typePPC = $filePPC->lstatType())) {
|
|
return complain(1, 'makeUniversal: lstat ppc: '.$!.' for:',
|
|
$filePPC->path());
|
|
}
|
|
if (defined($fileX86) && !defined($typeX86 = $fileX86->lstatType())) {
|
|
return complain(1, 'makeUniversal: lstat x86: '.$!.' for:',
|
|
$fileX86->path());
|
|
}
|
|
|
|
if (defined($filePPC) && defined($fileX86) && $typePPC != $typeX86) {
|
|
return complain(1, 'makeUniversal: incompatible types:',
|
|
$filePPC->path(),
|
|
$fileX86->path());
|
|
}
|
|
|
|
# $aSourceFile will contain a FileAttrCache object that will return
|
|
# the correct type data. It's used because it's possible for one of
|
|
# the two source files to be undefined (indicating a straight copy).
|
|
my ($aSourceFile);
|
|
if (defined($filePPC)) {
|
|
$aSourceFile = $filePPC;
|
|
}
|
|
else {
|
|
$aSourceFile = $fileX86;
|
|
}
|
|
|
|
if ($aSourceFile->lIsDir()) {
|
|
if ($gVerbosity >= 3 || $gDryRun) {
|
|
print('mkdir '.(argumentEscape($fileTargetPath))[0]."\n");
|
|
}
|
|
if (!$gDryRun && !mkdir($fileTargetPath)) {
|
|
return complain(1, 'makeUniversal: mkdir: '.$!.' for:',
|
|
$fileTargetPath);
|
|
}
|
|
|
|
my ($rv);
|
|
|
|
if (!($rv = makeUniversalDirectory($filePPC, $fileX86, $fileTargetPath))) {
|
|
# makeUniversalDirectory printed an error.
|
|
if ($isToplevel) {
|
|
command($gConfig{'cmd_rm'},'-rf','--',$fileTargetPath);
|
|
}
|
|
}
|
|
else {
|
|
# Touch the directory when leaving it. If unify is being run on an
|
|
# .app bundle, the .app might show up without an icon because the
|
|
# system might have found the .app before it was completely built.
|
|
# Touching it dirties it in LaunchServices' mind.
|
|
if ($gVerbosity >= 3) {
|
|
print('touch '.(argumentEscape($fileTargetPath))[0]."\n");
|
|
}
|
|
utime(undef, undef, $fileTargetPath);
|
|
}
|
|
|
|
return $rv;
|
|
}
|
|
elsif ($aSourceFile->lIsSymLink()) {
|
|
my ($linkPPC, $linkX86);
|
|
if (defined($filePPC) && !defined($linkPPC=readlink($filePPC->path()))) {
|
|
return complain(1, 'makeUniversal: readlink ppc: '.$!.' for:',
|
|
$filePPC->path());
|
|
}
|
|
if (defined($fileX86) && !defined($linkX86=readlink($fileX86->path()))) {
|
|
return complain(1, 'makeUniversal: readlink x86: '.$!.' for:',
|
|
$fileX86->path());
|
|
}
|
|
if (defined($filePPC) && defined($fileX86) && $linkPPC ne $linkX86) {
|
|
return complain(1, 'makeUniversal: symbolic links differ:',
|
|
$filePPC->path(),
|
|
$fileX86->path());
|
|
}
|
|
|
|
# $aLink here serves the same purpose as $aSourceFile in the enclosing
|
|
# block: it refers to the target of the symbolic link, whether there
|
|
# is one valid source or two.
|
|
my ($aLink);
|
|
if (defined($linkPPC)) {
|
|
$aLink = $linkPPC;
|
|
}
|
|
else {
|
|
$aLink = $linkX86;
|
|
}
|
|
|
|
if ($gVerbosity >= 3 || $gDryRun) {
|
|
print('ln -s '.
|
|
join(' ',argumentEscape($aLink, $fileTargetPath))."\n");
|
|
}
|
|
if (!$gDryRun && !symlink($aLink, $fileTargetPath)) {
|
|
return complain(1, 'makeUniversal: symlink: '.$!.' for:',
|
|
$aLink,
|
|
$fileTargetPath);
|
|
}
|
|
|
|
return 1;
|
|
}
|
|
elsif($aSourceFile->lIsRegularFile()) {
|
|
my ($machPPC, $machX86);
|
|
if (!defined($filePPC) || !defined($fileX86)) {
|
|
# One of the source files isn't present. The right thing to do is
|
|
# to just copy what does exist straight over, so skip Mach-O checks.
|
|
$machPPC = 0;
|
|
$machX86 = 0;
|
|
}
|
|
else {
|
|
if (!defined($machPPC=$filePPC->isMachO())) {
|
|
return complain(1, 'makeUniversal: isFileMachO ppc failed for:',
|
|
$filePPC->path());
|
|
}
|
|
if (!defined($machX86=$fileX86->isMachO())) {
|
|
return complain(1, 'makeUniversal: isFileMachO x86 failed for:',
|
|
$fileX86->path());
|
|
}
|
|
}
|
|
|
|
if ($machPPC != $machX86) {
|
|
return complain(1, 'makeUniversal: variant Mach-O attributes:',
|
|
$filePPC->path(),
|
|
$fileX86->path());
|
|
}
|
|
|
|
if ($machPPC) {
|
|
# makeUniversalFile will print an error if it fails.
|
|
return makeUniversalFile($filePPC, $fileX86, $fileTargetPath);
|
|
}
|
|
|
|
# Regular file. copyIfIdentical will print an error if it fails.
|
|
return copyIfIdentical($filePPC, $fileX86, $fileTargetPath);
|
|
}
|
|
|
|
# Special file, don't know how to handle.
|
|
return complain(1, 'makeUniversal: cannot handle special file:',
|
|
$filePPC->path(),
|
|
$fileX86->path());
|
|
}
|
|
|
|
# usage()
|
|
#
|
|
# Give the user a hand.
|
|
sub usage() {
|
|
print STDERR (
|
|
"usage: unify <ppc-path> <x86-path> <universal-path>\n".
|
|
" [--dry-run] (print what would be done)\n".
|
|
" [--only-one <action>] (skip, copy, fail; default=copy)\n".
|
|
" [--verbosity <level>] (0, 1, 2, 3; default=2)\n");
|
|
return;
|
|
}
|
|
|
|
# readZipCRCs($zipFile)
|
|
#
|
|
# $zipFile is the pathname to a zip file whose directory will be read.
|
|
# A reference to a hash is returned, with the member pathnames from the
|
|
# zip file as keys, and reasonably unique identifiers as values. The
|
|
# format of the values is not specified exactly, but does include the
|
|
# member CRCs and sizes and differentiates between files and directories.
|
|
# It specifically does not distinguish between modification times. On
|
|
# failure, prints a message and returns undef.
|
|
sub readZipCRCs($) {
|
|
my ($zipFile);
|
|
($zipFile) = @_;
|
|
|
|
my ($ze, $zip);
|
|
$zip = Archive::Zip->new();
|
|
|
|
if (($ze = $zip->read($zipFile)) != AZ_OK) {
|
|
complain(1, 'readZipCRCs: read error '.$ze.' for:',
|
|
$zipFile);
|
|
return undef;
|
|
}
|
|
|
|
my ($member, %memberCRCs, @memberList);
|
|
%memberCRCs = ();
|
|
@memberList = $zip->members();
|
|
|
|
foreach $member (@memberList) {
|
|
# Take a few of the attributes that identify the file and stuff them into
|
|
# the members hash. Directories will show up with size 0 and crc32 0,
|
|
# so isDirectory() is used to distinguish them from empty files.
|
|
$memberCRCs{$member->fileName()} = join(',', $member->isDirectory() ? 1 : 0,
|
|
$member->uncompressedSize(),
|
|
$member->crc32String());
|
|
}
|
|
|
|
return {%memberCRCs};
|
|
}
|
|
|
|
{
|
|
# FileAttrCache allows various attributes about a file to be cached
|
|
# so that if they are needed again after first use, no system calls
|
|
# will be made and the program won't need to hit the disk.
|
|
|
|
package FileAttrCache;
|
|
|
|
use Fcntl(':DEFAULT', ':mode');
|
|
|
|
# FileAttrCache->new($path)
|
|
#
|
|
# Creates a new FileAttrCache object for the file at path $path and
|
|
# returns it. The cache is not primed at creation time, values are
|
|
# fetched lazily as they are needed.
|
|
sub new($$) {
|
|
my ($class, $path, $proto, $this);
|
|
($proto, $path) = @_;
|
|
if (!($class = ref($proto))) {
|
|
$class = $proto;
|
|
}
|
|
$this = {
|
|
'path' => $path,
|
|
'lstat' => undef,
|
|
'lstatErrno' => 0,
|
|
'lstatInit' => 0,
|
|
'magic' => undef,
|
|
'magicErrno' => 0,
|
|
'magicErrMsg' => undef,
|
|
'magicInit' => 0,
|
|
'stat' => undef,
|
|
'statErrno' => 0,
|
|
'statInit' => 0,
|
|
};
|
|
bless($this, $class);
|
|
return($this);
|
|
}
|
|
|
|
# $FileAttrCache->isFat()
|
|
#
|
|
# Returns true if the file is a fat Mach-O file, false if it's not, and
|
|
# undef if an error occurs. See /usr/include/mach-o/fat.h.
|
|
sub isFat($) {
|
|
my ($magic, $this);
|
|
($this) = @_;
|
|
|
|
# magic() caches, there's no separate cache because isFat() doesn't hit
|
|
# the disk other than by calling magic().
|
|
|
|
if (!defined($magic = $this->magic())) {
|
|
return undef;
|
|
}
|
|
|
|
if ($magic == 0xcafebabe) {
|
|
return 1;
|
|
}
|
|
|
|
return 0;
|
|
}
|
|
|
|
# $FileAttrCache->isMachO()
|
|
#
|
|
# Returns true if the file is a Mach-O image (including a fat file), false
|
|
# if it's not, and undef if an error occurs. See
|
|
# /usr/include/mach-o/loader.h and /usr/include/mach-o/fat.h.
|
|
sub isMachO($) {
|
|
my ($magic, $this);
|
|
($this) = @_;
|
|
|
|
# magic() caches, there's no separate cache because isMachO() doesn't hit
|
|
# the disk other than by calling magic().
|
|
|
|
if (!defined($magic = $this->magic())) {
|
|
return undef;
|
|
}
|
|
|
|
# Accept Mach-O fat files or Mach-O thin files of either endianness.
|
|
if ($magic == 0xfeedface ||
|
|
$magic == 0xcefaedfe ||
|
|
$magic == 0xcafebabe) {
|
|
return 1;
|
|
}
|
|
|
|
return 0;
|
|
}
|
|
|
|
# $FileAttrCache->isZip()
|
|
#
|
|
# Returns true if the file is a zip file, false if it's not, and undef if
|
|
# an error occurs. See http://www.pkware.com/business_and_developers/developer/popups/appnote.txt .
|
|
sub isZip($) {
|
|
my ($magic, $this);
|
|
($this) = @_;
|
|
|
|
# magic() caches, there's no separate cache because isFat() doesn't hit
|
|
# the disk other than by calling magic().
|
|
|
|
if (!defined($magic = $this->magic())) {
|
|
return undef;
|
|
}
|
|
|
|
if ($magic == 0x504b0304) {
|
|
return 1;
|
|
}
|
|
|
|
return 0;
|
|
}
|
|
|
|
# $FileAttrCache->lIsExecutable()
|
|
#
|
|
# Wraps $FileAttrCache->lstat(), returning true if the file is has any,
|
|
# execute bit set, false if none are set, or undef if an error occurs.
|
|
# On error, $! is set to lstat's errno.
|
|
sub lIsExecutable($) {
|
|
my ($mode, $this);
|
|
($this) = @_;
|
|
|
|
if (!defined($mode = $this->lstatMode())) {
|
|
return undef;
|
|
}
|
|
|
|
return $mode & (S_IXUSR | S_IXGRP | S_IXOTH);
|
|
}
|
|
|
|
# $FileAttrCache->lIsDir()
|
|
#
|
|
# Wraps $FileAttrCache->lstat(), returning true if the file is a directory,
|
|
# false if it isn't, or undef if an error occurs. Because lstat is used,
|
|
# this will return false even if the file is a symlink pointing to a
|
|
# directory. On error, $! is set to lstat's errno.
|
|
sub lIsDir($) {
|
|
my ($type, $this);
|
|
($this) = @_;
|
|
|
|
if (!defined($type = $this->lstatType())) {
|
|
return undef;
|
|
}
|
|
|
|
return S_ISDIR($type);
|
|
}
|
|
|
|
# $FileAttrCache->lIsRegularFile()
|
|
#
|
|
# Wraps $FileAttrCache->lstat(), returning true if the file is a regular,
|
|
# file, false if it isn't, or undef if an error occurs. Because lstat is
|
|
# used, this will return false even if the file is a symlink pointing to a
|
|
# regular file. On error, $! is set to lstat's errno.
|
|
sub lIsRegularFile($) {
|
|
my ($type, $this);
|
|
($this) = @_;
|
|
|
|
if (!defined($type = $this->lstatType())) {
|
|
return undef;
|
|
}
|
|
|
|
return S_ISREG($type);
|
|
}
|
|
|
|
# $FileAttrCache->lIsSymLink()
|
|
#
|
|
# Wraps $FileAttrCache->lstat(), returning true if the file is a symbolic,
|
|
# link, false if it isn't, or undef if an error occurs. On error, $! is
|
|
# set to lstat's errno.
|
|
sub lIsSymLink($) {
|
|
my ($type, $this);
|
|
($this) = @_;
|
|
|
|
if (!defined($type = $this->lstatType())) {
|
|
return undef;
|
|
}
|
|
|
|
return S_ISLNK($type);
|
|
}
|
|
|
|
# $FileAttrCache->lstat()
|
|
#
|
|
# Wraps the lstat system call, providing a cache to speed up multiple
|
|
# lstat calls for the same file. See lstat(2) and lstat in perlfunc(1).
|
|
sub lstat($) {
|
|
my (@stat, $this);
|
|
($this) = @_;
|
|
|
|
# Use the cached lstat result.
|
|
if ($$this{'lstatInit'}) {
|
|
if (defined($$this{'lstatErrno'})) {
|
|
$! = $$this{'lstatErrno'};
|
|
}
|
|
return @{$$this{'lstat'}};
|
|
}
|
|
$$this{'lstatInit'} = 1;
|
|
|
|
if (!(@stat = CORE::lstat($$this{'path'}))) {
|
|
$$this{'lstatErrno'} = $!;
|
|
}
|
|
|
|
$$this{'lstat'} = [@stat];
|
|
return @stat;
|
|
}
|
|
|
|
# $FileAttrCache->lstatMode()
|
|
#
|
|
# Wraps $FileAttrCache->lstat(), returning the mode bits from the st_mode
|
|
# field, or undef if an error occurs. On error, $! is set to lstat's
|
|
# errno.
|
|
sub lstatMode($) {
|
|
my (@stat, $this);
|
|
($this) = @_;
|
|
|
|
if (!(@stat = $this->lstat())) {
|
|
return undef;
|
|
}
|
|
|
|
return S_IMODE($stat[2]);
|
|
}
|
|
|
|
# $FileAttrCache->lstatType()
|
|
#
|
|
# Wraps $FileAttrCache->lstat(), returning the type bits from the st_mode
|
|
# field, or undef if an error occurs. On error, $! is set to lstat's
|
|
# errno.
|
|
sub lstatType($) {
|
|
my (@stat, $this);
|
|
($this) = @_;
|
|
|
|
if (!(@stat = $this->lstat())) {
|
|
return undef;
|
|
}
|
|
|
|
return S_IFMT($stat[2]);
|
|
}
|
|
|
|
# $FileAttrCache->magic()
|
|
#
|
|
# Returns the "magic number" for the file by reading its first four bytes
|
|
# as a big-endian unsigned 32-bit integer and returning the result. If an
|
|
# error occurs, returns undef and prints diagnostic messages to stderr. If
|
|
# the file is shorter than 32 bits, returns -1. A cache is provided to
|
|
# speed multiple magic calls for the same file.
|
|
sub magic($) {
|
|
my ($this);
|
|
($this) = @_;
|
|
|
|
# Use the cached magic result.
|
|
if ($$this{'magicInit'}) {
|
|
if (defined($$this{'magicErrno'})) {
|
|
if (defined($$this{'magicErrMsg'})) {
|
|
complain(1, 'FileAttrCache::magic: '.$$this{'magicErrMsg'}.' for:',
|
|
$$this{'path'});
|
|
}
|
|
$! = $$this{'magicErrno'};
|
|
}
|
|
return $$this{'magic'};
|
|
}
|
|
|
|
$$this{'magicInit'} = 1;
|
|
|
|
my ($fh);
|
|
if (!sysopen($fh, $$this{'path'}, O_RDONLY)) {
|
|
$$this{'magicErrno'} = $!;
|
|
$$this{'magicErrMsg'} = 'open "'.$$this{'path'}.'": '.$!;
|
|
complain(1, 'FileAttrCache::magic: '.$$this{'magicErrMsg'}.' for:',
|
|
$$this{'path'});
|
|
return undef;
|
|
}
|
|
|
|
$! = 0;
|
|
my ($bytes, $magic);
|
|
if (!defined($bytes = sysread($fh, $magic, 4))) {
|
|
$$this{'magicErrno'} = $!;
|
|
$$this{'magicErrMsg'} = 'read "'.$$this{'path'}.'": '.$!;
|
|
complain(1, 'FileAttrCache::magic: '.$$this{'magicErrMsg'}.' for:',
|
|
$$this{'path'});
|
|
close($fh);
|
|
return undef;
|
|
}
|
|
|
|
close($fh);
|
|
|
|
if ($bytes != 4) {
|
|
# The file is too short, didn't read a magic number. This isn't really
|
|
# an error. Return an unlikely value.
|
|
$$this{'magic'} = -1;
|
|
return -1;
|
|
}
|
|
|
|
$$this{'magic'} = unpack('N', $magic);
|
|
return $$this{'magic'};
|
|
}
|
|
|
|
# $FileAttrCache->path()
|
|
#
|
|
# Returns the file's pathname.
|
|
sub path($) {
|
|
my ($this);
|
|
($this) = @_;
|
|
return $$this{'path'};
|
|
}
|
|
|
|
# $FileAttrCache->stat()
|
|
#
|
|
# Wraps the stat system call, providing a cache to speed up multiple
|
|
# stat calls for the same file. If lstat() has already been called and
|
|
# the file is not a symbolic link, the cached lstat() result will be used.
|
|
# See stat(2) and lstat in perlfunc(1).
|
|
sub stat($) {
|
|
my (@stat, $this);
|
|
($this) = @_;
|
|
|
|
# Use the cached stat result.
|
|
if ($$this{'statInit'}) {
|
|
if (defined($$this{'statErrno'})) {
|
|
$! = $$this{'statErrno'};
|
|
}
|
|
return @{$$this{'stat'}};
|
|
}
|
|
|
|
$$this{'statInit'} = 1;
|
|
|
|
# If lstat has already been called, and the file isn't a symbolic link,
|
|
# use the cached lstat result.
|
|
if ($$this{'lstatInit'} && !$$this{'lstatErrno'} &&
|
|
!S_ISLNK(${$$this{'lstat'}}[2])) {
|
|
$$this{'stat'} = $$this{'lstat'};
|
|
return @{$$this{'stat'}};
|
|
}
|
|
|
|
if (!(@stat = CORE::stat($$this{'path'}))) {
|
|
$$this{'statErrno'} = $!;
|
|
}
|
|
|
|
$$this{'stat'} = [@stat];
|
|
return @stat;
|
|
}
|
|
|
|
# $FileAttrCache->statSize()
|
|
#
|
|
# Wraps $FileAttrCache->stat(), returning the st_size field, or undef
|
|
# undef if an error occurs. On error, $! is set to stat's errno.
|
|
sub statSize($) {
|
|
my (@stat, $this);
|
|
($this) = @_;
|
|
|
|
if (!(@stat = $this->lstat())) {
|
|
return undef;
|
|
}
|
|
|
|
return $stat[7];
|
|
}
|
|
}
|