1#!/usr/perl5/bin/perl -w 2# 3# CDDL HEADER START 4# 5# The contents of this file are subject to the terms of the 6# Common Development and Distribution License, Version 1.0 only 7# (the "License"). You may not use this file except in compliance 8# with the License. 9# 10# You can obtain a copy of the license at usr/src/OPENSOLARIS.LICENSE 11# or http://www.opensolaris.org/os/licensing. 12# See the License for the specific language governing permissions 13# and limitations under the License. 14# 15# When distributing Covered Code, include this CDDL HEADER in each 16# file and include the License file at usr/src/OPENSOLARIS.LICENSE. 17# If applicable, add the following below this CDDL HEADER, with the 18# fields enclosed by brackets "[]" replaced with your own identifying 19# information: Portions Copyright [yyyy] [name of copyright owner] 20# 21# CDDL HEADER END 22# 23# 24# ident "%Z%%M% %I% %E% SMI" 25# 26# Copyright 2004 Sun Microsystems, Inc. All rights reserved. 27# Use is subject to license terms. 28# 29 30# 31# This utility program creates the profiles of the binaries to be 32# checked. 33# 34# The dynamic profiling is done by running ldd -r on the binary with 35# LD_DEBUG=files,bindings and parsing the linker debug output. 36# 37# The static profiling (gathering of .text symbols) is done by calling 38# the utility program static_prof. 39# 40 41require 5.005; 42use strict; 43use locale; 44use POSIX qw(locale_h); 45use Sun::Solaris::Utils qw(textdomain gettext); 46use File::Basename; 47use File::Path; 48 49use lib qw(/usr/lib/abi/appcert); 50use AppcertUtil; 51 52setlocale(LC_ALL, ""); 53textdomain(TEXT_DOMAIN); 54 55use vars qw( 56 $tmp_prof_dir 57); 58 59set_clean_up_exit_routine(\&clean_up_exit); 60 61import_vars_from_environment(); 62 63signals('on', \&interrupted); 64 65set_working_dir(); 66 67profile_objects(); 68 69clean_up(); 70 71exit 0; 72 73# 74# working_dir has been imported by import_vars_from_environment() from 75# appcert. A sanity check is performed here to make sure it exists. 76# 77sub set_working_dir 78{ 79 if (! defined($working_dir) || ! -d $working_dir) { 80 exiter("$command_name: " . sprintf(gettext( 81 "cannot locate working directory: %s\n"), $working_dir)); 82 } 83} 84 85# 86# Routine called when interrupted by user (e.g. SIGINT). 87# 88sub interrupted 89{ 90 $SIG{$_[0]} = 'DEFAULT'; 91 signals('off'); 92 clean_up_exit(1); 93} 94 95# 96# Does the cleanup then exits with return code $rc. Note: The utility 97# routine exiter() calls this routine. 98# 99sub clean_up_exit 100{ 101 my ($rc) = @_; 102 $rc = 0 unless ($rc); 103 104 clean_up(); 105 exit $rc; 106} 107 108# 109# General cleanup activities. 110# 111sub clean_up 112{ 113 if (defined($tmp_prof_dir) && -d $tmp_prof_dir) { 114 rmtree($tmp_prof_dir); 115 } 116} 117 118# 119# Top level routine to loop over the objects and call the profiling 120# routines on each. 121# 122sub profile_objects 123{ 124 # Make a tmp directory for the profiling work. 125 $tmp_prof_dir = create_tmp_dir($tmp_dir); 126 127 if (! -d $tmp_prof_dir) { 128 exiter(nocreatedir($tmp_prof_dir, $!)); 129 } 130 131 my ($dir, $path_to_object); 132 133 # 134 # Loop over each object item in the working_dir. 135 # - $dir will be each one of these object directories. 136 # - $path_to_object will be the corresponding actual path 137 # to the the binary to be profiled. 138 # Output will usually be placed down in $dir, e.g. "$dir/profile.static" 139 # 140 141 my $cnt = -1; 142 my $last_i; 143 while (defined($dir = next_dir_name())) { 144 $cnt++; 145 if ($block_max ne '') { 146 next if ($cnt < $block_min || $cnt >= $block_max); 147 } 148 149 $last_i = $cnt; 150 151 # Map object output directory to actual path of the object: 152 $path_to_object = dir_name_to_path($dir); 153 154 if (! -f $path_to_object) { 155 exiter(nopathexist($path_to_object, $!)); 156 } 157 158 # Profile it: 159 160 emsg(gettext("profiling: %s\n"), $path_to_object); 161 162 static_profile($path_to_object, $dir); 163 164 dynamic_profile($path_to_object, $dir); 165 } 166 167 # Only try this after everything has been initially profiled. 168 if (! $block_max || $last_i >= $binary_count - 1) { 169 redo_unbound_profile(); 170 } 171 clean_up(); # Remove any tmp dirs and files. 172} 173 174# 175# Runs utility program static_prof on the object and places results in 176# output directory. 177# 178sub static_profile($$) 179{ 180 my ($object, $output_dir) = @_; 181 182 # This is the location of static_prof's output file: 183 184 my $outfile = "$output_dir/profile.static"; 185 186 # It is consumed by static_check_object() in symcheck. 187 188 # 189 # Do not run on *completely* statically linked objects. This 190 # case will be caught and noted in the dynamic profiling and 191 # checking. 192 # 193 my $skip_it; 194 if (is_statically_linked($object)) { 195 $skip_it = "STATICALLY_LINKED"; 196 } elsif (! is_elf($object)) { 197 $skip_it = "NON_ELF"; 198 } 199 200 my $static_prof_fh = do { local *FH; *FH }; 201 if (defined($skip_it)) { 202 open($static_prof_fh, ">$outfile") || 203 exiter(nofile($outfile, $!)); 204 205 print $static_prof_fh "#SKIPPED_TEST: $skip_it\n"; 206 close($static_prof_fh); 207 208 return; 209 } 210 211 # 212 # system() when run in the following manner will prevent the 213 # shell from expanding any strange characters in $object. Quotes 214 # around '$object' would be almost as safe. since excluded 215 # earlier the cases where it contains the ' character. 216 # 217 system("$appcert_lib_dir/static_prof", '-p', '-s', '-o', $outfile, 218 $object); 219 220 if ($? != 0) { 221 open($static_prof_fh, ">$outfile") || 222 exiter(nofile($outfile, $!)); 223 224 # 225 # For completeness, we'll use elfdump to record the 226 # static profile for 64 bit binaries, although the 227 # static linking problems only occur for 32-bit 228 # applications. 229 # 230 my ($prof, $sym); 231 $prof = ''; 232 my $elfdump_fh = do { local *FH; *FH }; 233 if (open($elfdump_fh, "$cmd_elfdump -s -N .dynsym '$object' " . 234 " 2>/dev/null |")) { 235 while (<$elfdump_fh>) { 236 chomp; 237 if (/\s\.text\s+(\S+)$/) { 238 $sym = $1; 239 if (! /\bFUNC\b/) { 240 next; 241 } 242 if (/\bGLOB\b/) { 243 $prof .= "$object|TEXT|GLOB|" . 244 "FUNC|$sym\n"; 245 } else { 246 $prof .= "$object|TEXT|WEAK|" . 247 "FUNC|$sym\n"; 248 } 249 } 250 } 251 close($elfdump_fh); 252 } 253 if ($prof ne '') { 254 my $line; 255 print $static_prof_fh "#generated by symprof/elfdump\n"; 256 print $static_prof_fh "#dtneeded:"; 257 foreach $line (split(/\n/, cmd_output_dump($object))) { 258 if ($line =~ /\bNEEDED\s+(\S+)/) { 259 print $static_prof_fh " $1"; 260 } 261 } 262 print $static_prof_fh "\n"; 263 print $static_prof_fh $prof; 264 } else { 265 print $static_prof_fh "#SKIPPED_TEST: " . 266 "PROFILER_PROGRAM_static_prof_RETURNED:$?\n"; 267 } 268 close($static_prof_fh); 269 270 271 return; 272 } 273 274 # Also store the dtneededs from the static profile output. 275 my $dtneeded = "$output_dir/info.dtneeded"; 276 277 my $dtneeded_fh = do { local *FH; *FH }; 278 open($dtneeded_fh, ">$dtneeded") || 279 exiter(nofile($dtneeded, $!)); 280 281 open($static_prof_fh, "<$outfile") || 282 exiter(nofile($outfile, $!)); 283 284 my $lib; 285 while (<$static_prof_fh>) { 286 287 next unless (/^\s*#/); 288 289 if (/^\s*#\s*dtneeded:\s*(\S.*)$/) { 290 foreach $lib (split(/\s+/, $1)) { 291 next if ($lib eq ''); 292 print $dtneeded_fh "$lib\n"; 293 } 294 last; 295 } 296 } 297 close($dtneeded_fh); 298 close($static_prof_fh); 299} 300 301# 302# Top level subroutine for doing a dynamic profile of an object. It 303# calls get_dynamic_profile() which handles the details of the actual 304# profiling and returns the newline separated "preprocessed format" to 305# this subroutine. 306# 307# The records are then processed and placed in the output directory. 308# 309sub dynamic_profile 310{ 311 my ($object, $output_dir) = @_; 312 313 my ($profile, $line, $tmp); 314 315 # This is the profile output file. 316 my $outfile = "$output_dir/profile.dynamic"; 317 318 $profile = get_dynamic_profile($object); 319 320 if ($profile =~ /^ERROR:\s*(.*)$/) { 321 # There was some problem obtaining the dynamic profile 322 my $msg = $1; 323 my $errfile = "$output_dir/profile.dynamic.errors"; 324 325 my $profile_error_fh = do { local *FH; *FH }; 326 open($profile_error_fh, ">>$errfile") || 327 exiter(nofile($errfile, $!)); 328 329 $msg =~ s/\n/ /g; 330 $msg =~ s/;/,/g; 331 print $profile_error_fh $msg, "\n"; 332 close($profile_error_fh); 333 334 # Write a comment to the profile file as well: 335 my $profile_fh = do { local *FH; *FH }; 336 open($profile_fh, ">$outfile") || 337 exiter(nofile($outfile, $!)); 338 print $profile_fh "#NO_BINDINGS_FOUND $msg\n"; 339 close($profile_fh); 340 341 return; 342 } 343 344 my ($filter, $filtee, $from, $to, $sym); 345 my ($type, $saw_bindings, $all_needed); 346 my (%filter_map, %symlink_map); 347 348 # Resolve the symlink of the object, if any. 349 $symlink_map{$object} = follow_symlink($object); 350 351 # 352 # Collect the filter or static linking info first. Since the 353 # filter info may be used to alias libraries, it is safest to do 354 # it before any bindings processing. that is why we iterate 355 # through $profile twice. 356 # 357 my @dynamic_profile_array = split(/\n/, $profile); 358 359 foreach $line (@dynamic_profile_array) { 360 361 if ($line =~ /^FILTER_AUX:(.*)$/) { 362 # 363 # Here is the basic example of an auxiliary filter: 364 # 365 # FILTER: /usr/lib/libc.so.1 366 # FILTEE: /usr/platform/sun4u/lib/libc_psr.so.1 367 # 368 # The app links against symbol memcpy() in 369 # libc.so.1 at build time. Now, at run time IF 370 # memcpy() is provided by libc_psr.so.1 then 371 # that "code" is used, otherwise it backs off to 372 # use the memcpy()in libc.so.1. The 373 # libc_psr.so.1 doesn't even have to exist. 374 # 375 # The dynamic linker happily informs us that it 376 # has found (and will bind to) memcpy() in 377 # /usr/platform/sun4u/lib/libc_psr.so.1. We 378 # want to alias libc_psr.so.1 => libc.so.1. 379 # Why? 380 # - less models to maintain. Note the symlink 381 # situation in /usr/platform. 382 # - libc_psr.so.1 is versioned, but we would be 383 # incorrect since it has memcpy() as SUNWprivate 384 # 385 # Therefore we record this aliasing in the hash 386 # %filter_map. This will be used below to 387 # replace occurrences of the FILTEE string by 388 # the FILTER string. Never the other way round. 389 # 390 391 ($filter, $filtee) = split(/\|/, $1, 2); 392 $filter_map{$filtee} = $filter; 393 394 # Map the basenames too: 395 $filter = basename($filter); 396 $filtee = basename($filtee); 397 $filter_map{$filtee} = $filter; 398 399 } elsif ($line =~ /^FILTER_STD:(.*)$/) { 400 401 # 402 # Here is the basic example(s) of a standard filter: 403 # 404 # FILTER: /usr/lib/libsys.so.1 405 # FILTEE: /usr/lib/libc.so.1 406 # 407 # Here is another: 408 # 409 # FILTER: /usr/lib/libw.so.1 410 # FILTEE: /usr/lib/libc.so.1 411 # 412 # Here is a more perverse one, libxnet.so.1 has 3 413 # filtees: 414 # 415 # FILTER: /usr/lib/libxnet.so.1 416 # FILTEE: /usr/lib/{libsocket.so.1,libnsl.so.1,libc.so.1} 417 # 418 # The important point to note about standard 419 # filters is that they contain NO CODE AT ALL. 420 # All of the symbols in the filter MUST be found 421 # in (and bound to) the filtee(s) or there is a 422 # relocation error. 423 # 424 # The app links against symbol getwc() in 425 # libw.so.1 at build time. Now, at run time 426 # getwc() is actually provided by libc.so.1. 427 # 428 # The dynamic linker happily informs us that it 429 # has found (and will bind to) getwc() in 430 # libc.so.1. IT NEVER DIRECTLY TELLS US getwc was 431 # actually referred to in libw.so.1 432 # 433 # So, unless we open a model file while 434 # PROFILING, we cannot figure out which ones 435 # come from libw.so.1 and which ones come from 436 # libc.so.1. In one sense this is too bad: the 437 # libw.so.1 structure is lost. 438 # 439 # The bottom line is we should not alias 440 # libc.so.1 => libw.so.1 (FILTEE => FILTER) as 441 # we did above with FILTER_AUX. That would be a 442 # disaster. (would say EVERYTHING in libc came 443 # from libw!) 444 # 445 # So we DO NOT store the alias in this case, this 446 # leads to: 447 # - more models to maintain. 448 # 449 # Thus we basically skip this info. 450 # EXCEPT for one case, libdl.so.1, see below. 451 # 452 453 ($filter, $filtee) = split(/\|/, $1, 2); 454 455 # 456 # The dlopen(), ... family of functions in 457 # libdl.so.1 is implemented as a filter for 458 # ld.so.1. We DO NOT want to consider a symbol 459 # model for ld.so.1. So in this case alone we 460 # want to alias ld.so.1 => libdl.so.1 461 # 462 # 463 # We only need to substitute the standard filter 464 # libdl.so.n. Record the alias in that case. 465 # 466 if ($filter =~ /\blibdl\.so\.\d+/) { 467 $filter_map{$filtee} = $filter; 468 469 # Map basenames too: 470 $filter = basename($filter); 471 $filtee = basename($filtee); 472 $filter_map{$filtee} = $filter; 473 } 474 475 } elsif ($line =~ /^DYNAMIC_PROFILE_SKIPPED_NOT_ELF/ || 476 $line =~ /^STATICALLY_LINKED:/) { 477 # 478 # This info will go as a COMMENT into the 479 # output. n.b.: there is no checking whether 480 # this piece of info is consistent with the rest 481 # of the profile output. 482 # 483 # The $message string will come right after the 484 # header, and before the bindings (if any). See 485 # below where we write to the PROF filehandle. 486 # 487 488 my $profile_msg_fh = do { local *FH; *FH }; 489 open($profile_msg_fh, ">>$outfile") || 490 exiter(nofile($outfile, $!)); 491 print $profile_msg_fh "#$line\n"; 492 close($profile_msg_fh); 493 494 } elsif ($line =~ /^NEEDED_FOUND:(.*)$/) { 495 # 496 # These libraries are basically information 497 # contained in the ldd "libfoo.so.1 => 498 # /usr/lib/libfoo.so.1" output lines. It is the 499 # closure of the neededs (not just the directly 500 # needed ones). 501 # 502 503 $all_needed .= $1 . "\n"; 504 } 505 } 506 507 # 508 # Now collect the bindings info: 509 # 510 # Each BINDING record refers to 1 symbol. After manipulation 511 # here it will go into 1 record into the profile output. 512 # 513 # What sort of manipulations? Looking below reveals: 514 # 515 # - we apply the library FILTER_AUX aliases in %filter_map 516 # - for shared objects we resolve symbolic links to the actual 517 # files they point to. 518 # - we may be in a mode where we do not store full paths of 519 # the shared objects, e.g. /usr/lib/libc.so.1, but rather 520 # just their basename "libc.so.1" 521 # 522 # There are exactly four(4) types of bindings that will be 523 # returned to us by get_dynamic_profile(). See 524 # get_dynamic_profile() and Get_ldd_Profile() for more details. 525 # 526 # Here are the 4 types: 527 # 528 # BINDING_DIRECT:from|to|sym 529 # The object being profiled is the "from" here! 530 # It directly calls "sym" in library "to". 531 # 532 # BINDING_INDIRECT:from|to|sym 533 # The object being profiled is NOT the "from" here. 534 # "from" is a shared object, and "from" calls "sym" in 535 # library "to". 536 # 537 # BINDING_REVERSE:from|to|sym 538 # The shared object "from" makes a reverse binding 539 # all the way back to the object being profiled! We call 540 # this *REVERSE*. "to" is the object being profiled. 541 # 542 # BINDING_UNBOUND:from|sym 543 # object "from" wants to call "sym", but "sym" was 544 # not found! We didn't find the "to", and so no 545 # "to" is passed to us. 546 # 547 548 my $put_DIRECT_in_the_UNBOUND_record; 549 550 $saw_bindings = 0; 551 # 552 # Start the sorting pipeline that appends to the output file. 553 # It will be written to in the following loop. 554 # 555 # Tracing back $outfile to $outdir to $working_dir, one sees $outfile 556 # should have no single-quote characters. We double check it does not 557 # before running the command. 558 # 559 if ($outfile =~ /'/) { 560 exiter(norunprog("|$cmd_sort -t'|' +1 | $cmd_uniq >> '$outfile'")); 561 } 562 563 my $prof_fh = do { local *FH; *FH }; 564 open($prof_fh, "|$cmd_sort -t'|' +1 | $cmd_uniq >> '$outfile'") || 565 exiter(norunprog("|$cmd_sort -t'|' +1 | $cmd_uniq >> '$outfile'", 566 $!)); 567 local($SIG{'PIPE'}) = sub { 568 exiter(norunprog( 569 "|$cmd_sort -t'|' +1 | $cmd_uniq >> '$outfile'", $!)); 570 }; 571 572 foreach $line (@dynamic_profile_array) { 573 574 if ($line =~ /^BINDING_([^:]+):(.*)$/) { 575 576 $type = $1; 577 578 if ($type eq 'UNBOUND') { 579 # 580 # If the symbol was unbound, there is no 581 # "to" library. We make an empty "to" 582 # value so as to avoid special casing 583 # "to" all through the code that 584 # follows. It is easy to verify no 585 # matter what happens with the $to 586 # variable, it will NOT be printed to the 587 # profile output file in the UNBOUND 588 # case. 589 # 590 591 ($from, $sym) = split(/\|/, $2, 2); 592 $to = ''; 593 594 } else { 595 # Otherwise, we have the full triple: 596 597 ($from, $to, $sym) = split(/\|/, $2, 3); 598 } 599 600 # 601 # We record here information to be used in 602 # writing out UNBOUND records, namely if the 603 # "from" happened to also be the object being 604 # profiled. In that case The string "*DIRECT*" 605 # will be placed in the "*UNBOUND*" record, 606 # otherwise the "from" will stand as is in the 607 # "*UNBOUND*" record. We do this check here 608 # before the filter_map is applied. The chances 609 # of it making a difference is small, but we had 610 # best to do it here. 611 # 612 if (files_equal($from, $object)) { 613 # 614 # Switch to indicate placing *DIRECT* in 615 # the *UNBOUND* line, etc. 616 # 617 $put_DIRECT_in_the_UNBOUND_record = 1; 618 } else { 619 $put_DIRECT_in_the_UNBOUND_record = 0; 620 } 621 622 # 623 # See if there is a filter name that "aliases" 624 # either of the "from" or "to" libraries, if so 625 # then rename it. 626 # 627 if ($to ne '' && $filter_map{$to}) { 628 $to = $filter_map{$to}; 629 } 630 if ($type ne 'DIRECT' && $filter_map{$from}) { 631 $from = $filter_map{$from}; 632 } 633 634 # 635 # Record symlink information. 636 # 637 # Note that follow_symlink returns the file 638 # name itself when the file is not a symlink. 639 # 640 # Work out if either "from" or "to" are 641 # symlinks. For efficiency we keep them in the 642 # %symlink_map hash. Recall that we are in a 643 # loop here, so why do libc.so.1 200 times? 644 # 645 if ($from ne '') { 646 if (! exists($symlink_map{$from})) { 647 $symlink_map{$from} = 648 follow_symlink($from); 649 } 650 } 651 if ($to ne '') { 652 if (! exists($symlink_map{$to})) { 653 $symlink_map{$to} = 654 follow_symlink($to); 655 } 656 } 657 658 # 659 # Now make the actual profile output line. Construct 660 # it in $tmp and then append it to $prof_fh pipeline. 661 # 662 $tmp = ''; 663 664 if ($type eq "DIRECT") { 665 $tmp = "$object|*DIRECT*|$to|$sym"; 666 } elsif ($type eq "INDIRECT") { 667 $tmp = "$object|$from|$to|$sym"; 668 } elsif ($type eq "REVERSE") { 669 $tmp = "$object|*REVERSE*|$from|$sym"; 670 } elsif ($type eq "UNBOUND") { 671 if ($put_DIRECT_in_the_UNBOUND_record) { 672 $tmp = 673 "$object|*DIRECT*|*UNBOUND*|$sym"; 674 } else { 675 $tmp = "$object|$from|*UNBOUND*|$sym"; 676 } 677 } else { 678 exiter("$command_name: " . sprintf(gettext( 679 "unrecognized ldd(1) LD_DEBUG " . 680 "bindings line: %s\n"), $line)); 681 } 682 683 # write it to the sorting pipeline: 684 print $prof_fh $tmp, "\n"; 685 $saw_bindings = 1; 686 } elsif ($line =~ /^DYNAMIC_PROFILE_SKIPPED_NOT_ELF/) { 687 # ignore no bindings warning for non-ELF 688 $saw_bindings = 1; 689 } 690 } 691 692 if (! $saw_bindings) { 693 print $prof_fh "#NO_BINDINGS_FOUND\n"; 694 } 695 close($prof_fh); 696 if ($? != 0) { 697 exiter(norunprog( 698 "|$cmd_sort -t'|' +1 | $cmd_uniq >> '$outfile'", $!)); 699 } 700 701 # Print out the library location and symlink info. 702 $outfile = "$output_dir/profile.dynamic.objects"; 703 704 my $objects_fh = do { local *FH; *FH }; 705 open($objects_fh, ">$outfile") || exiter(nofile($outfile, $!)); 706 707 my ($var, $val); 708 while (($var, $val) = each(%ENV)) { 709 if ($var =~ /^LD_/) { 710 print $objects_fh "#info: $var=$val\n"; 711 } 712 } 713 714 my $obj; 715 foreach $obj (sort(keys(%symlink_map))) { 716 next if ($obj eq ''); 717 print $objects_fh "$obj => $symlink_map{$obj}\n"; 718 } 719 close($objects_fh); 720 721 # Print out ldd shared object resolution. 722 $outfile = "$output_dir/profile.dynamic.ldd"; 723 724 my $ldd_prof_fh = do { local *FH; *FH }; 725 open($ldd_prof_fh, ">$outfile") || exiter(nofile($outfile, $!)); 726 727 if (defined($all_needed)) { 728 print $ldd_prof_fh $all_needed; 729 } 730 close($ldd_prof_fh); 731 732} 733 734# 735# If the users environment is not the same when running symprof as when 736# running their application, the dynamic linker cannot resolve all of 737# the dynamic bindings and we get "unbound symbols". 738# redo_unbound_profile attempts to alleviate this somewhat. In 739# particular, for shared objects that do not have all of their 740# dependencies recorded, it attempts to use binding information in the 741# other *executables* under test to supplement the binding information 742# for the shared object with unbound symbols. This is not the whole 743# story (e.g. dlopen(3L)), but it often helps considerably. 744# 745sub redo_unbound_profile 746{ 747 my ($dir, $path_to_object); 748 my ($profile, $total, $count); 749 my (%unbound_bins); 750 751 # 752 # Find the objects with unbound symbols. Put them in the list 753 # %unbound_bins. 754 # 755 $total = 0; 756 while (defined($dir = next_dir_name())) { 757 758 $profile = "$dir/profile.dynamic"; 759 my $profile_fh = do { local *FH; *FH }; 760 if (! -f $profile || ! open($profile_fh, "<$profile")) { 761 next; 762 } 763 764 $count = 0; 765 while (<$profile_fh>) { 766 next if (/^\s*#/); 767 $count++ if (/\|\*UNBOUND\*\|/); 768 } 769 close($profile_fh); 770 771 $unbound_bins{$dir} = $count if ($count); 772 $total += $count; 773 } 774 775 # we are done if no unbounds are detected. 776 return unless (%unbound_bins); 777 return if ($total == 0); 778 779 my (%dtneededs_lookup_full, %dtneededs_lookup_base); 780 781 # Read in *ALL* objects dt_neededs. 782 783 my ($soname, $base, $full); 784 while (defined($dir = next_dir_name())) { 785 786 $profile = "$dir/profile.dynamic.ldd"; 787 my $all_neededs_fh = do { local *FH; *FH }; 788 if (! open($all_neededs_fh, "<$profile")) { 789 # this is a heuristic, so we skip on to the next 790 next; 791 } 792 793 while (<$all_neededs_fh>) { 794 chop; 795 next if (/^\s*#/); 796 # save the dtneeded info: 797 ($soname, $full) = split(/\s+=>\s+/, $_); 798 799 if ($full !~ /not found|\)/) { 800 $dtneededs_lookup_full{$full}{$dir} = 1; 801 } 802 if ($soname !~ /not found|\)/) { 803 $base = basename($soname); 804 $dtneededs_lookup_base{$base}{$dir} = 1; 805 } 806 } 807 close($all_neededs_fh); 808 } 809 810 emsg("\n" . gettext( 811 "re-profiling binary objects with unbound symbols") . " ...\n"); 812 813 # Now combine the above info with each object having unbounds: 814 815 my $uref = \%unbound_bins; 816 foreach $dir (keys(%unbound_bins)) { 817 818 # Map object output directory to the actual path of the object: 819 $path_to_object = dir_name_to_path($dir); 820 821 # 822 # Here is the algorithm: 823 # 824 # 1) binary with unbounds must be a shared object. 825 # 826 # 2) check if it is in the dtneeded of other product binaries. 827 # if so, use the dynamic profile of those binaries 828 # to augment the bindings of the binary with unbounds 829 # 830 831 if (! -f $path_to_object) { 832 exiter(nopathexist($path_to_object, $!)); 833 } 834 835 # only consider shared objects (e.g. with no DTNEEDED recorded) 836 if (! is_shared_object($path_to_object)) { 837 next; 838 } 839 840 $base = basename($path_to_object); 841 842 my (@dirlist); 843 844 my $result = 0; 845 846 if (defined($dtneededs_lookup_base{$base})) { 847 # the basename is on another's dtneededs: 848 @dirlist = keys(%{$dtneededs_lookup_base{$base}}); 849 # try using the bindings of these executables: 850 $result = 851 try_executables_bindings($dir, $uref, @dirlist); 852 } 853 if ($result) { 854 # we achieved some improvements and so are done: 855 next; 856 } 857 858 # Otherwise, try objects that have our full path in their 859 # dtneededs: 860 @dirlist = (); 861 foreach $full (keys(%dtneededs_lookup_full)) { 862 if (! files_equal($path_to_object, $full)) { 863 next; 864 } 865 push(@dirlist, keys(%{$dtneededs_lookup_full{$full}})); 866 } 867 if (@dirlist) { 868 $result = 869 try_executables_bindings($dir, $uref, @dirlist); 870 } 871 } 872 emsg("\n"); 873} 874 875# 876# We are trying to reduce unbound symbols of shared objects/libraries 877# under test that *have not* recorded their dependencies (i.e. 878# DTNEEDED's). So we look for Executables being checked that have *this* 879# binary ($path_to_object, a shared object) on *its* DTNEEDED. If we 880# find one, we use those bindings. 881# 882sub try_executables_bindings 883{ 884 my ($dir, $uref, @dirlist) = @_; 885 886 my $path_to_object = dir_name_to_path($dir); 887 888 # 889 # N.B. The word "try" here means for a binary (a shared library, 890 # actually) that had unbound symbols, "try" to use OTHER 891 # executables binding info to resolve those unbound symbols. 892 # 893 # At least one executable needs this library; we select the one 894 # with minimal number of its own unbounds. 895 # 896 my (%sorting_list); 897 my (@executables_to_try); 898 my ($dir2, $cnt); 899 foreach $dir2 (@dirlist) { 900 next if (! defined($dir2)); 901 next if ($dir2 eq $dir); 902 if (exists($uref->{$dir2})) { 903 $cnt = $uref->{$dir2}; 904 } else { 905 # 906 # This binary is not on the unbounds list, so 907 # give it the highest priority. 908 # 909 $cnt = 0; 910 } 911 $sorting_list{"$dir2 $cnt"} = $dir2; 912 } 913 914 foreach my $key (reverse(sort_on_count(keys %sorting_list))) { 915 push(@executables_to_try, $sorting_list{$key}); 916 } 917 918 my ($my_new_count, $my_new_profile, %my_new_symbols); 919 my ($object, $caller, $callee, $sym, $profile); 920 my $reprofiled = 0; 921 922 my ($line, $path2); 923 924 foreach $dir2 (@executables_to_try) { 925 $path2 = dir_name_to_path($dir2); 926 emsg(gettext( 927 "re-profiling: %s\n" . 928 "using: %s\n"), $path_to_object, $path2); 929 930 # read the other binary's profile 931 932 $profile = "$dir2/profile.dynamic"; 933 if (! -f $profile) { 934 next; 935 } 936 937 my $prof_try_fh = do { local *FH; *FH }; 938 open($prof_try_fh, "<$profile") || 939 exiter(nofile($profile, $!)); 940 941 # initialize for the next try: 942 $my_new_profile = ''; 943 $my_new_count = 0; 944 %my_new_symbols = (); 945 946 # try to find bindings that involve us ($dir) 947 while (<$prof_try_fh>) { 948 chop($line = $_); 949 next if (/^\s*#/); 950 next if (/^\s*$/); 951 ($object, $caller, $callee, $sym) = 952 split(/\|/, $line, 4); 953 954 if ($caller eq '*REVERSE*') { 955 next if ($callee =~ /^\*.*\*$/); 956 if (! files_equal($callee, $path_to_object)) { 957 next; 958 } 959 960 $my_new_profile .= 961 "$callee|*DIRECT*|REVERSE_TO:" . 962 "$object|$sym\n"; 963 964 $my_new_symbols{$sym}++; 965 $my_new_count++; 966 967 } elsif (files_equal($caller, $path_to_object)) { 968 $my_new_profile .= 969 "$caller|*DIRECT*|$callee|$sym\n"; 970 971 $my_new_symbols{$sym}++; 972 $my_new_count++; 973 } 974 } 975 close($prof_try_fh); 976 977 next if (! $my_new_count); 978 979 # modify our profile with the new information: 980 $profile = "$dir/profile.dynamic"; 981 if (! rename($profile, "$profile.0") || ! -f "$profile.0") { 982 return 0; 983 } 984 my $prof_orig_fh = do { local *FH; *FH }; 985 if (! open($prof_orig_fh, "<$profile.0")) { 986 rename("$profile.0", $profile); 987 return 0; 988 } 989 my $prof_fh = do { local *FH; *FH }; 990 if (! open($prof_fh, ">$profile")) { 991 rename("$profile.0", $profile); 992 return 0; 993 } 994 my $resolved_from = dir_name_to_path($dir2); 995 print $prof_fh "# REDUCING_UNBOUNDS_VIA_PROFILE_FROM: " . 996 "$resolved_from\n"; 997 998 while (<$prof_orig_fh>) { 999 if (/^\s*#/) { 1000 print $prof_fh $_; 1001 next; 1002 } 1003 chop($line = $_); 1004 ($object, $caller, $callee, $sym) = 1005 split(/\|/, $line, 4); 1006 if (! exists($my_new_symbols{$sym})) { 1007 print $prof_fh $_; 1008 next; 1009 } 1010 print $prof_fh "# RESOLVED_FROM=$resolved_from: $_"; 1011 } 1012 close($prof_orig_fh); 1013 print $prof_fh "# NEW_PROFILE:\n" . $my_new_profile; 1014 close($prof_fh); 1015 1016 $reprofiled = 1; 1017 last; 1018 } 1019 return $reprofiled; 1020} 1021 1022# 1023# This routine calls get_ldd_output on the object and parses the 1024# LD_DEBUG output. Returns a string containing the information in 1025# standard form. 1026# 1027sub get_dynamic_profile 1028{ 1029 my ($object) = @_; 1030 1031 # Check if the object is statically linked: 1032 1033 my $str; 1034 if (! is_elf($object)) { 1035 return "DYNAMIC_PROFILE_SKIPPED_NOT_ELF"; 1036 } elsif (is_statically_linked($object)) { 1037 $str = cmd_output_file($object); 1038 return "STATICALLY_LINKED: $str"; 1039 } 1040 1041 # Get the raw ldd output: 1042 my $ldd_output = get_ldd_output($object); 1043 1044 if ($ldd_output =~ /^ERROR:/) { 1045 # some problem occurred, pass the error upward: 1046 return $ldd_output; 1047 } 1048 1049 # variables for manipulating the output: 1050 my ($line, $filters, $neededs, $rest); 1051 my ($tmp, $tmp2, @bindings); 1052 1053 # Now parse it: 1054 1055 foreach $line (split(/\n/, $ldd_output)) { 1056 1057 if ($line =~ /^\d+:\s*(.*)$/) { 1058 # LD_DEBUG profile line, starts with "NNNNN:" 1059 $tmp = $1; 1060 next if ($tmp eq ''); 1061 1062 if ($tmp =~ /^binding (.*)$/) { 1063 # 1064 # First look for: 1065 # binding file=/bin/pagesize to \ 1066 # file=/usr/lib/libc.so.1: symbol `exit' 1067 # 1068 $tmp = $1; 1069 push(@bindings, ldd_binding_line($1, $object)); 1070 1071 } elsif ($tmp =~ /^file=\S+\s+(.*)$/) { 1072 # 1073 # Next look for: 1074 # file=/usr/platform/SUNW,Ultra-1/\ 1075 # lib/libc_psr.so.1; filtered by /usr... 1076 # file=libdl.so.1; needed by /usr/lib/libc.so.1 1077 # 1078 $rest = trim($1); 1079 1080 if ($rest =~ /^filtered by /) { 1081 $filters .= 1082 ldd_filter_line($tmp); 1083 } elsif ($rest =~ /^needed by /) { 1084 $neededs .= 1085 ldd_needed_line($tmp, $object); 1086 } 1087 1088 } 1089 1090 } elsif ($line =~ /^stdout:(.*)$/) { 1091 # LD_DEBUG stdout line: 1092 1093 $tmp = trim($1); 1094 next if ($tmp eq ''); 1095 1096 if ($tmp =~ /\s+=>\s+/) { 1097 # 1098 # First look for standard dependency 1099 # resolution lines: 1100 # 1101 # libsocket.so.1 => /usr/lib/libsocket.so.1 1102 # 1103 # Note that these are *all* of the 1104 # needed shared objects, not just the 1105 # directly needed ones. 1106 # 1107 $tmp =~ s/\s+/ /g; 1108 $neededs .= "NEEDED_FOUND:$tmp" . "\n"; 1109 1110 } elsif ($tmp =~ /symbol not found: (.*)$/) { 1111 # 1112 # Next look for unbound symbols: 1113 # symbol not found: gethz (/usr/\ 1114 # local/bin/gethz) 1115 # 1116 1117 $tmp = trim($1); 1118 ($tmp, $tmp2) = split(/\s+/, $tmp, 2); 1119 $tmp2 =~ s/[\(\)]//g; # trim off (). 1120 1121 # $tmp is the symbol, $tmp2 is the 1122 # calling object. 1123 1124 push(@bindings, 1125 "BINDING_UNBOUND:$tmp2|$tmp" . "\n" 1126 ); 1127 } 1128 } 1129 } 1130 1131 # Return the output: 1132 my $ret = ''; 1133 $ret .= $filters if (defined($filters)); 1134 $ret .= $neededs if (defined($neededs)); 1135 $ret .= join('', @bindings); 1136 1137 return $ret; 1138} 1139 1140# 1141# Routine used to parse a LD_DEBUG "binding" line. 1142# 1143# Returns "preprocessed format line" if line is ok, or 1144# null string otherwise. 1145# 1146sub ldd_binding_line 1147{ 1148 my ($line, $object) = @_; 1149 1150 my ($from, $to, $sym); 1151 1152 my ($t1, $t2, $t3); # tmp vars for regex output 1153 1154 # 1155 # Working on a line like: 1156 # 1157 # binding file=/bin/pagesize to file=/usr/lib/libc.so.1: symbol `exit' 1158 # 1159 # (with the leading "binding " removed). 1160 # 1161 1162 if ($line =~ /^file=(\S+)\s+to file=(\S+)\s+symbol(.*)$/) { 1163 # 1164 # The following trim off spaces, ', `, ;, and :, from 1165 # the edges so if the filename had those there could 1166 # be a problem. 1167 # 1168 $from = $1; 1169 $to = $2; 1170 $sym = $3; 1171 # 1172 # guard against future changes to the LD_DEBUG output 1173 # (i.e. information appended to the end) 1174 # 1175 $sym =~ s/'\s+.*$//; 1176 1177 $to =~ s/:$//; 1178 1179 $sym =~ s/[\s:;`']*$//; 1180 $sym =~ s/^[\s:;`']*//; 1181 1182 } elsif ($line =~ /^file=(.+) to file=(.+): symbol (.*)$/) { 1183 # This will catch spaces, but is less robust. 1184 $t1 = $1; 1185 $t2 = $2; 1186 $t3 = $3; 1187 # 1188 # guard against future changes to the LD_DEBUG output 1189 # (i.e. information appended to the end) 1190 # 1191 $t3 =~ s/'\s+.*$//; 1192 1193 $from = wclean($t1, 1); 1194 $to = wclean($t2, 1); 1195 $sym = wclean($t3); 1196 1197 } else { 1198 return ''; 1199 } 1200 1201 if ($from eq '' || $to eq '' || $sym eq '') { 1202 return ''; 1203 } 1204 1205 # 1206 # OK, we have 3 files: $from, $to, $object 1207 # Which, if any, are the same file? 1208 # 1209 # Note that we have not yet done the Filter library 1210 # substitutions yet. So one cannot be too trusting of the file 1211 # comparisons done here. 1212 # 1213 1214 if (files_equal($from, $to, 0)) { 1215 # 1216 # We skip the "from" = "to" case 1217 # (could call this: BINDING_SELF). 1218 # 1219 return ''; 1220 } elsif (files_equal($object, $from, 0)) { 1221 # DIRECT CASE (object calls library): 1222 return "BINDING_DIRECT:$from|$to|$sym" . "\n"; 1223 } elsif (files_equal($object, $to, 0)) { 1224 # REVERSE CASE (library calls object): 1225 return "BINDING_REVERSE:$from|$to|$sym" . "\n"; 1226 } else { 1227 # 1228 # INDIRECT CASE (needed library calls library): 1229 # (this will not be a library calling itself because 1230 # we skip $from eq $to above). 1231 # 1232 return "BINDING_INDIRECT:$from|$to|$sym" . "\n"; 1233 } 1234} 1235 1236# 1237# Routine used to parse a LD_DEBUG "filtered by" line. 1238# 1239# Returns "preprocessed format line" if line is ok, or null string 1240# otherwise. 1241# 1242sub ldd_filter_line 1243{ 1244 my ($line) = @_; 1245 1246 my ($filter, $filtee); 1247 1248 # 1249 # Working on a line like: 1250 # 1251 # file=/usr/platform/SUNW,Ultra-1/lib/libc_psr.so.1; \ 1252 # filtered by /usr/lib/libc.so.1 1253 # 1254 1255 my ($t1, $t2); # tmp vars for regex output 1256 1257 if ($line =~ /file=(\S+)\s+filtered by\s+(\S.*)$/) { 1258 $t1 = $1; 1259 $t2 = $2; 1260 $filtee = wclean($t1); 1261 $filter = wclean($t2); 1262 } elsif ($line =~ /file=(.+); filtered by (.*)$/) { 1263 $t1 = $1; 1264 $t2 = $2; 1265 $filtee = wclean($t1, 1); 1266 $filter = wclean($t2, 1); 1267 } else { 1268 return ''; 1269 } 1270 1271 if ($filtee eq '' || $filter eq '') { 1272 return ''; 1273 } 1274 # 1275 # What kind of filter is $filter? 1276 # STANDARD (contains no "real code", e.g. libxnet.so.1), or 1277 # AUXILIARY (provides "code" if needed, but 1278 # prefers to pass filtee's "code", e.g. libc.so.1) 1279 # 1280 # LD_DEBUG output does not indicate this, so dump -Lv is run on it 1281 # in filter_lib_type: 1282 # 1283 1284 my $type = 'unknown'; 1285 1286 $type = filter_lib_type($filter); 1287 1288 if ($type eq 'STD') { 1289 return "FILTER_STD:$filter|$filtee" . "\n"; 1290 } elsif ($type eq 'AUX') { 1291 return "FILTER_AUX:$filter|$filtee" . "\n"; 1292 } else { 1293 return ''; 1294 } 1295} 1296 1297# 1298# Routine used to parse a LD_DEBUG "needed by" line. 1299# 1300# Returns "preprocessed format line" if line is ok, or the null string 1301# otherwise. 1302# 1303sub ldd_needed_line 1304{ 1305 my ($line, $object) = @_; 1306 1307 my ($thing_needed, $file); 1308 1309 my ($t1, $t2); # tmp variables for regex output. 1310 1311 # 1312 # Working on a line like: 1313 # 1314 # file=libdl.so.1; needed by /usr/lib/libc.so.1 1315 # 1316 1317 if ($line =~ /file=(\S+)\s+needed by\s+(\S.*)$/) { 1318 $t1 = $1; 1319 $t2 = $2; 1320 $thing_needed = wclean($t1); 1321 $file = wclean($t2); 1322 } elsif ($line =~ /file=(.+); needed by (.*)$/) { 1323 $t1 = $1; 1324 $t2 = $2; 1325 $thing_needed = wclean($t1, 1); 1326 $file = wclean($t2, 1); 1327 } else { 1328 return ''; 1329 } 1330 1331 if ($thing_needed eq '' || $file eq '') { 1332 return ''; 1333 } 1334 1335 # 1336 # Note that $thing_needed is not a path to a file, just the 1337 # short name unresolved, e.g. "libc.so.1". The next line of the 1338 # LD_DEBUG output would tell us where $thing_needed is resolved 1339 # to. 1340 # 1341 1342 if (files_equal($object, $file)) { 1343 return "NEEDED_DIRECT:$thing_needed|$file" . "\n"; 1344 } else { 1345 return "NEEDED_INDIRECT:$thing_needed|$file" . "\n"; 1346 } 1347} 1348 1349# 1350# Routine to clean up a "word" string from ldd output. 1351# 1352# This is specialized for removing the stuff surrounding files and 1353# symbols in the LD_DEBUG output. It is usually a file name or symbol 1354# name. 1355# 1356sub wclean 1357{ 1358 my ($w, $keep_space) = @_; 1359 1360 if (! $keep_space) { 1361 # make sure leading/trailing spaces are gone. 1362 $w =~ s/[\s:;`']*$//; # get rid of : ; ' and ` 1363 $w =~ s/^[\s:;`']*//; 1364 } else { 1365 $w =~ s/[:;`']*$//; # get rid of : ; ' and ` 1366 $w =~ s/^[:;`']*//; 1367 } 1368 1369 return $w; 1370} 1371 1372# 1373# This routine runs ldd -r on the object file with LD_DEBUG flags turned 1374# on. It collects the stdout and the LD_DEBUG profile data for the 1375# object (it must skip the LD_DEBUG profile data for /usr/bin/ldd 1376# /bin/sh, or any other extraneous processes). 1377# 1378# It returns the profile data as a single string with \n separated 1379# records. Records starting with "stdout: " are the stdout lines, 1380# Records starting with "NNNNN: " are the LD_DEBUG lines. Our caller 1381# must split and parse those lines. 1382# 1383# If there is some non-fatal error, it returns a 1-line string like: 1384# ERROR: <error-message> 1385# 1386sub get_ldd_output 1387{ 1388 1389 my ($object) = @_; 1390 1391 my ($tmpdir, $outfile, $errfile); 1392 1393 if (! -f $object) { 1394 exiter(nopathexist($object)); 1395 } 1396 1397 # We use the tmp_dir for our work: 1398 $tmpdir = $tmp_prof_dir; 1399 1400 # Clean out the tmpdir. 1401 if ($tmpdir !~ m,^/*$,) { 1402 unlink(<$tmpdir/*>); 1403 # 1404 # The following puts xgettext(1) back on track. It is 1405 # confused and believes it is inside a C-style /* comment */ 1406 # 1407 my $unused = "*/"; 1408 } 1409 1410 # Output files for collecting output of the ldd -r command: 1411 $errfile = "$tmpdir/stderr"; 1412 $outfile = "$tmpdir/stdout"; 1413 1414 my ($rc, $msg, $child, $result); 1415 1416 # 1417 # This forking method should have 2 LD_DEBUG bind.<PID> files 1418 # one for ldd and the other for $object. system() could have 1419 # another from the shell. 1420 # 1421 1422 # Fork off a child: 1423 $child = fork(); 1424 1425 # 1426 # Note: the file "/tmp/.../bind.$child" should be the "ldd" 1427 # profile, but we do not want to depend upon that. 1428 # 1429 1430 if (! defined($child)) { 1431 # Problem forking: 1432 exiter(sprintf(gettext( 1433 "cannot fork for command: ldd -r %s: %s\n"), $object, $!)); 1434 1435 } elsif ($child == 0) { 1436 1437 # Reopen std output to the desired output files: 1438 open(STDOUT, ">$outfile") || 1439 exiter(nofile($outfile, $!)); 1440 1441 open(STDERR, ">$errfile") || 1442 exiter(nofile($errfile, $!)); 1443 1444 # 1445 # Set the env to turn on debugging from the linker: 1446 # 1447 $ENV{'LD_DEBUG'} = "files,bindings"; 1448 $ENV{'LD_DEBUG_OUTPUT'} = "$tmpdir/bind"; 1449 1450 # 1451 # Set LD_NOAUXFLTR to avoid auxiliary filters (e.g. libc_psr) 1452 # since they are not of interest to the public/private 1453 # symbol status and confuse things more than anything else. 1454 # 1455 $ENV{'LD_NOAUXFLTR'} = "1"; 1456 1457 # Run ldd -r: 1458 c_locale(1); 1459 exec($cmd_ldd, '-r', $object); 1460 exit 1; # only reached if exec fails. 1461 } else { 1462 wait; # Wait for children to finish. 1463 $rc = $?; # Record exit status. 1464 $msg = $!; 1465 } 1466 1467 # Check the exit status: 1468 if ($rc != 0) { 1469 if (-s $errfile) { 1470 my $tmp; 1471 my $errfile_fh = do { local *FH; *FH }; 1472 if (open($errfile_fh, "<$errfile")) { 1473 while (<$errfile_fh>) { 1474 if (/ldd:/) { 1475 $tmp = $_; 1476 last; 1477 } 1478 } 1479 close($errfile_fh); 1480 } 1481 if (defined($tmp)) { 1482 chomp($tmp); 1483 if ($tmp =~ /ldd:\s*(\S.*)$/) { 1484 $tmp = $1; 1485 } 1486 if ($tmp =~ /^[^:]+:\s*(\S.*)$/) { 1487 my $t = $1; 1488 if ($t !~ /^\s*$/) { 1489 $tmp = $t; 1490 } 1491 } 1492 $msg = $tmp if ($tmp !~ /^\s*$/); 1493 } 1494 } 1495 emsg("%s", norunprog("$cmd_ldd -r $object", "$msg\n")); 1496 $msg =~ s/\n/ /g; 1497 $msg =~ s/;/,/g; 1498 $msg = sprintf("ERROR: " . gettext( 1499 "Error running: ldd -r LD_DEBUG: %s"), $msg); 1500 return $msg; 1501 } 1502 1503 # 1504 # We now have all the output files created. We read them and 1505 # merge them into one long string to return to whoever called 1506 # us. The caller will parse it, not us. Our goal here is to 1507 # just return the correct LD_DEBUG profile data. 1508 # 1509 1510 if (-f "$tmpdir/stdout") { 1511 my $out_fh = do { local *FH; *FH }; 1512 if (! open($out_fh, "<$tmpdir/stdout")) { 1513 exiter(nofile("$tmpdir/stdout", $!)); 1514 } 1515 while (<$out_fh>) { 1516 # Add the special prefix for STDOUT: 1517 $result .= "stdout: $_"; 1518 } 1519 close($out_fh); 1520 } 1521 1522 my ($file, $count, $goodone, $ok, $aok, @file); 1523 1524 $count = 0; 1525 1526 my $prevline; 1527 1528 # Loop over each "bind.NNNNN" file in the tmp directory: 1529 foreach $file (<$tmpdir/bind.*>) { 1530 1531 # Open it for reading: 1532 my $ldd_file_fh = do { local *FH; *FH }; 1533 if (! open($ldd_file_fh, "<$file")) { 1534 exiter(nofile($file, $!)); 1535 } 1536 1537 # 1538 # ok = 1 means this file we are reading the profile file 1539 # corresponding to $object. We set ok = 0 as soon as we 1540 # discover otherwise. 1541 # 1542 $ok = 1; 1543 1544 # 1545 # $aok = 1 means always OK. I.e. we are definitely in the 1546 # correct profile. 1547 # 1548 $aok = 0; 1549 1550 # 1551 # this variable will hold the previous line so that we 1552 # can skip adjacent duplicates. 1553 # 1554 $prevline = ''; 1555 1556 my $idx; 1557 1558 while (<$ldd_file_fh>) { 1559 1560 # 1561 # This check is done to perform a simple 1562 # uniq'ing of the output. Non-PIC objects have 1563 # lots of duplicates, many of them right after 1564 # each other. 1565 # 1566 1567 next if ($_ eq $prevline); 1568 $prevline = $_; 1569 1570 # 1571 # Check to see if this is the wrong profile 1572 # file: The ones we know about are "ldd" and 1573 # "sh". If the object under test is ever "ldd" 1574 # or "sh" this will fail. 1575 # 1576 if ($aok) { 1577 ; 1578 } elsif ($ok) { 1579 # 1580 # checks line: 1581 # file=ldd; analyzing [ RTLD_GLOBAL RTLD_LAZY ] 1582 # 1583 if (/\bfile=\S+\b(ldd|sh)\b/) { 1584 $ok = 0; 1585 } else { 1586 $idx = 1587 index($_, " file=$object; analyzing"); 1588 $aok = 1 if ($idx != -1); 1589 } 1590 } 1591 1592 # We can skip this file as soon as we see $ok = 0. 1593 last unless ($ok); 1594 1595 # Gather the profile output into a string: 1596 $file[$count] .= $_; 1597 } 1598 1599 # 1600 # Note that this one is the desired profile 1601 # (i.e. if $ok is still true): 1602 # 1603 $goodone .= "$count," if ($ok); 1604 1605 # On to the next $file: 1606 close($ldd_file_fh); 1607 $count++; 1608 } 1609 1610 if (defined($goodone)) { 1611 $goodone =~ s/,$//; # Trim the last comma off. 1612 } 1613 1614 # If we have none or more than one "good one" we are in trouble: 1615 if (! defined($goodone) || ($goodone !~ /^\d+$/) || ($goodone =~ /,/)) { 1616 1617 # 1618 # Note that this is the first point at which we would detect 1619 # a problem with the checking of SUID/SGID objects, although 1620 # in theory we could have skipped these objects earlier. 1621 # We prefer to let the linker, ld.so.1, indicate this failure 1622 # and then we catch it and diagnose it here. 1623 # 1624 my $suid = is_suid($object); 1625 1626 if ($suid == 1) { 1627 $result = "ERROR: " . gettext( 1628 "SUID - ldd(1) LD_DEBUG profile failed"); 1629 } elsif ($suid == 2) { 1630 $result = "ERROR: " . gettext( 1631 "SGID - ldd(1) LD_DEBUG profile failed"); 1632 } else { 1633 $result = "ERROR: " . gettext( 1634 "could not get ldd(1) LD_DEBUG profile output"); 1635 } 1636 1637 } else { 1638 # Append the correct profile to the result and return it: 1639 $result .= $file[$goodone]; 1640 } 1641 1642 # Tidy up our mess by cleaning out the tmpdir. 1643 unlink(<$tmpdir/*>) if ($tmpdir !~ m,^/*$,); 1644 1645 return $result; 1646} 1647