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