1# 2# Copyright 2005 Sun Microsystems, Inc. All rights reserved. 3# Use is subject to license terms. 4# 5# CDDL HEADER START 6# 7# The contents of this file are subject to the terms of the 8# Common Development and Distribution License, Version 1.0 only 9# (the "License"). You may not use this file except in compliance 10# with the License. 11# 12# You can obtain a copy of the license at usr/src/OPENSOLARIS.LICENSE 13# or http://www.opensolaris.org/os/licensing. 14# See the License for the specific language governing permissions 15# and limitations under the License. 16# 17# When distributing Covered Code, include this CDDL HEADER in each 18# file and include the License file at usr/src/OPENSOLARIS.LICENSE. 19# If applicable, add the following below this CDDL HEADER, with the 20# fields enclosed by brackets "[]" replaced with your own identifying 21# information: Portions Copyright [yyyy] [name of copyright owner] 22# 23# CDDL HEADER END 24# 25 26# 27# This module contains utility routines and data for use by the appcert 28# programs: appcert, symprof, symcheck, and symreport. 29# 30 31package AppcertUtil; 32 33require 5.005; 34use strict; 35use locale; 36use Getopt::Std; 37use POSIX qw(locale_h); 38use Sun::Solaris::Utils qw(textdomain gettext); 39use File::Basename; 40use File::Path; 41 42BEGIN { 43 use Exporter(); 44 use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS); 45 46 @ISA = qw(Exporter); 47 @EXPORT = qw( 48 $command_name 49 $object_dir 50 $solaris_library_ld_path 51 $uname_p 52 $working_dir 53 $appcert_lib_dir 54 $batch_report 55 $binary_count 56 $block_min 57 $block_max 58 $tmp_dir 59 60 $cmd_dump 61 $cmd_elfdump 62 $cmd_file 63 $cmd_find 64 $cmd_ldd 65 $cmd_ls 66 $cmd_more 67 $cmd_pvs 68 $cmd_sort 69 $cmd_uname 70 $cmd_uniq 71 72 @lib_index_loaded 73 74 %lib_index_definition 75 %text 76 %model_tweak 77 %skip_symbols 78 %scoped_symbol 79 %scoped_symbol_all 80 %warnings_bind 81 %warnings_desc 82 %warnings_match 83 84 &object_to_dir_name 85 &dir_name_to_path 86 &next_dir_name 87 &cmd_output_file 88 &cmd_output_dump 89 &all_ldd_neededs 90 &all_ldd_neededs_string 91 &direct_syms 92 &import_vars_from_environment 93 &export_vars_to_environment 94 &c_locale 95 &overall_result_code 96 &trim 97 &sort_on_count 98 &print_line 99 &list_format 100 &emsg 101 &pmsg 102 &nofile 103 &nopathexist 104 &norunprog 105 &nocreatedir 106 &exiter 107 &set_clean_up_exit_routine 108 &signals 109 &create_tmp_dir 110 &dir_is_empty 111 &follow_symlink 112 &is_statically_linked 113 &is_elf 114 &is_shared_object 115 &is_aout 116 &is_suid 117 &bin_type 118 &files_equal 119 &purge_caches 120 &filter_lib_type 121 &load_model_index 122 &load_misc_check_databases 123 ); 124 125 @EXPORT_OK = (); 126 127 %EXPORT_TAGS = (); 128} 129 130use vars @EXPORT; 131use vars @EXPORT_OK; 132 133use vars qw( 134 $lib_match_initialized 135 136 %lib_index 137 %lib_index_loaded 138 %shared_object_index 139 140 %file_inode_cache 141 %file_exists_cache 142 %filter_lib_cache 143 %lib_match_cache 144 %cmd_output_file_cache 145 %cmd_output_dump_cache 146 %all_ldd_neededs_cache 147); 148 149my $clean_up_exit_routine; 150my $tmp_dir_count = 0; 151my $next_dir_name_dh; 152my $LC_ALL = ''; 153 154# Get the name of the program: 155$command_name = basename($0); 156 157$cmd_dump = '/usr/ccs/bin/dump'; 158$cmd_elfdump = '/usr/ccs/bin/elfdump'; 159$cmd_file = '/usr/has/bin/file'; 160$cmd_find = '/usr/bin/find'; 161$cmd_ldd = '/usr/bin/ldd'; 162$cmd_ls = '/usr/bin/ls'; 163$cmd_more = '/usr/bin/more'; 164$cmd_pvs = '/usr/bin/pvs'; 165$cmd_sort = '/usr/bin/sort'; 166$cmd_uname = '/usr/bin/uname'; 167$cmd_uniq = '/usr/bin/uniq'; 168 169chomp($uname_p = `$cmd_uname -p`); 170 171 172# Initialize constants: 173 174$solaris_library_ld_path = "/usr/openwin/lib:/usr/dt/lib"; 175 176# Prefix for every object's profiling (etc) subdir in $working_dir. 177$object_dir = 'objects/'; 178 179$text{'Summary_Result_None_Checked'} = gettext( 180 "No binaries were checked."); 181$text{'Summary_Result_Some_Failed'} = gettext( 182 "Potential binary stability problem(s) detected."); 183$text{'Summary_Result_Some_Incomplete'} = gettext( 184 "No stability problems detected, but not all binaries were checked."); 185$text{'Summary_Result_All_Passed'} = gettext( 186 "No binary stability problems detected."); 187 188 189$text{'Message_Private_Symbols_Check_Outfile'} = <<"END"; 190# 191# <binary>|<abi>|<caller>|<callee>|private|<symbol> 192# 193END 194 195$text{'Message_Public_Symbols_Check_Outfile'} = 196 $text{'Message_Private_Symbols_Check_Outfile'}; 197$text{'Message_Public_Symbols_Check_Outfile'} =~ s/private/public/g; 198 199# 200# Maps a filesystem path of a binary object to a subdirectory name (in 201# $working_dir). $working_dir is NOT prepended. 202# 203# Maps, e.g., /home/auser/bin/netscape.sparc 204# ===> objects/:=home=auser=bin=netscape.sparc 205# 206sub object_to_dir_name 207{ 208 my ($filename) = @_; 209 210 my $dirname = $filename; 211 212 # protect any percents there: 213 $dirname =~ s,%,%%,g; 214 215 # protect any equals there: 216 $dirname =~ s,=,%=,g; 217 218 # now change slashes to equals: 219 $dirname =~ s,/,=,g; 220 221 # 222 # Prepend "objects/" and ":" tag to avoid dirname starting 223 # with "=" or "." 224 # 225 $dirname = $object_dir . ':' . $dirname; 226 227 return $dirname; 228} 229 230# 231# Takes the application output data directory and returns the path to 232# the actual binary. 233# 234sub dir_name_to_path 235{ 236 my ($dirname) = @_; 237 my $path = ''; 238 239 if (! -f "$dirname/info.path") { 240 exiter(nofile("$dirname/info.path", $!)); 241 } else { 242 my $info_path_fh = do { local *FH; *FH }; 243 open($info_path_fh, "<$dirname/info.path") || 244 exiter(nofile("$dirname/info.path", $!)); 245 chomp($path = <$info_path_fh>); 246 close($info_path_fh); 247 } 248 249 return $path; 250} 251 252# 253# This subroutine repeatly returns the object dirnames in the 254# working_dir. The full path to the dirname is returned. "undef" is 255# returned when all have been cycled through. 256# 257sub next_dir_name 258{ 259 # object directory: 260 my $object_directory = $working_dir; 261 $object_directory .= "/" . $object_dir if ($object_dir); 262 263 # Check if we have the directory handle already open: 264 if (! defined($next_dir_name_dh)) { 265 # If not, then opendir it: 266 $next_dir_name_dh = do { local *FH; *FH }; 267 if (! opendir($next_dir_name_dh, $object_directory)) { 268 exiter(nodir($object_directory, $!)); 269 } 270 } 271 272 my $dirname; 273 274 # 275 # Loop over directory entries until one matches the magic tag 276 # "object:" Return undef when done reading the directory. 277 # 278 while (1) { 279 $dirname = readdir($next_dir_name_dh); 280 281 if (! defined($dirname)) { 282 # Done with dir. Clean up for next time: 283 closedir($next_dir_name_dh); 284 undef($next_dir_name_dh); 285 return undef; 286 } elsif ($dirname =~ m,^:,) { 287 # Return the full path to object's directory: 288 return "$object_directory/$dirname"; 289 } 290 } 291} 292 293# 294# When appcert started up, it stored the file(1) output in the 295# app's output directory (appcert: record_binary()). This subroutine 296# retrieves it. If it cannot find it, it runs the file command 297# instead. The result is stored in memory in %cmd_output_file_cache 298# 299# Returns the single line of "file" output including the "\n". It 300# returns the null string if it had trouble, usually only if filename 301# doesn't exist. 302# 303sub cmd_output_file 304{ 305 my ($filename) = @_; 306 307 # Check if we have it cached: 308 if (exists($cmd_output_file_cache{$filename})) { 309 return $cmd_output_file_cache{$filename}; 310 } 311 312 # Otherwise, try to look it up in the $working_dir: 313 my $outfile = object_to_dir_name($filename); 314 $outfile = "$working_dir/$outfile/info.file"; 315 316 my $str; 317 318 if (-f $outfile) { 319 my $file_cmd_fh = do { local *FH; *FH }; 320 if (open($file_cmd_fh, "<$outfile")) { 321 $str = <$file_cmd_fh>; 322 close($file_cmd_fh); 323 } 324 } 325 326 # Otherwise run file(1) on it: 327 if (! defined($str) && -f $filename && $filename !~ /'/) { 328 c_locale(1); 329 $str = `$cmd_file '$filename' 2>/dev/null`; 330 c_locale(0); 331 } 332 333 $cmd_output_file_cache{$filename} = $str; 334 335 return $str; 336} 337 338# 339# When appcert started up, it stored the /usr/ccs/bin/dump output in the 340# app's output directory (appcert: record_binary()). This subroutine 341# retrieves it. If it cannot find it, it runs the dump -Lv command 342# instead. The result is stored in memory in %cmd_output_dump_cache 343# 344# Returns the "dump -Lv" output. It returns the null string if it had 345# trouble, usually only if filename doesn't exist. 346# 347sub cmd_output_dump 348{ 349 my ($filename) = @_; 350 351 # Check if we have it cached: 352 if (exists($cmd_output_dump_cache{$filename})) { 353 return $cmd_output_dump_cache{$filename}; 354 } 355 356 # Otherwise, try to look it up in the $working_dir: 357 my $outfile = object_to_dir_name($filename); 358 $outfile = "$working_dir/$outfile/info.dump"; 359 360 my $str; 361 362 if (-f $outfile) { 363 my $dump_cmd_fh = do { local *FH; *FH }; 364 if (open($dump_cmd_fh, "<$outfile")) { 365 while (<$dump_cmd_fh>) { 366 $str .= $_; 367 } 368 close($dump_cmd_fh); 369 } 370 } 371 372 # Otherwise run /usr/ccs/bin/dump -Lv on it: 373 if (! defined($str) && -f $filename && $filename !~ /'/) { 374 c_locale(1); 375 $str = `$cmd_dump -Lv '$filename' 2>/dev/null`; 376 c_locale(0); 377 } 378 379 $cmd_output_dump_cache{$filename} = $str; 380 381 return $str; 382} 383 384# 385# When symprof runs it stores the /usr/bin/ldd output in the app's 386# output directory (symprof: dynamic_profile()). This subroutine 387# retrieves it. If it cannot find it, it runs the ldd command instead. 388# The result is stored in memory in %all_ldd_neededs_cache 389# 390# Returns a "neededs hash" as output. The keys being the things needed 391# (left side of " => ") and the values are the resolution (right side of 392# " => "). It returns the null hash if it had trouble, usually only if 393# filename doesn't even exist, or if the object is not dynamically 394# linked. 395# 396sub all_ldd_neededs 397{ 398 my ($filename) = @_; 399 400 my (%all_neededs); 401 402 my $output; 403 404 # Check if we have it cached: 405 if (exists($all_ldd_neededs_cache{$filename})) { 406 $output = $all_ldd_neededs_cache{$filename}; 407 } 408 409 if (! defined($output)) { 410 # Otherwise, try to look it up in the $working_dir: 411 my $outfile = object_to_dir_name($filename); 412 $outfile = "$working_dir/$outfile/profile.dynamic.ldd"; 413 414 if (-f $outfile) { 415 my $all_neededs_fh = do { local *FH; *FH }; 416 if (open($all_neededs_fh, "<$outfile")) { 417 while (<$all_neededs_fh>) { 418 next if (/^\s*#/); 419 $output .= $_; 420 } 421 } 422 close($all_neededs_fh); 423 } 424 } 425 426 my ($str, $line, $l1, $l2); 427 if (! defined($output) && -f $filename && $filename !~ /'/) { 428 # Otherwise run /usr/bin/ldd on it: 429 c_locale(1); 430 $str = `$cmd_ldd '$filename' 2>/dev/null`; 431 c_locale(0); 432 foreach $line (split(/\n/, $str)) { 433 $line = trim($line); 434 $output .= "$line\n"; 435 } 436 } 437 438 if (! defined($output)) { 439 # 440 # Set the output to the null string so following loop 441 # will do nothing and thus the empty hash will be 442 # returned. 443 # 444 $output = ''; 445 } 446 447 $all_ldd_neededs_cache{$filename} = $output; 448 449 foreach $line (split(/\n/, $output)) { 450 ($l1, $l2) = split(/\s*=>\s*/, $line); 451 $l1 = trim($l1); 452 $l2 = trim($l2); 453 $all_neededs{$l1} = $l2; 454 if ($l2 !~ /file not found/) { 455 $all_neededs{$l2} = $l2; 456 } 457 } 458 459 return %all_neededs; 460} 461 462# 463# Create a string with all of the needed objects (direct and indirect). 464# This is intended for object name matching. See the 'needed' MATCH 465# entries in etc.warn. 466# 467sub all_ldd_neededs_string 468{ 469 my ($filename) = @_; 470 my (%hash, $key); 471 my $str = ''; 472 %hash = all_ldd_neededs($filename); 473 foreach $key (keys(%hash)) { 474 $str .= "$key $hash{$key}\n"; 475 } 476 return $str; 477} 478 479# 480# Create a list with all of the directly bound symbols. This is 481# intended for symbol call matching. See the 'syms' MATCH entries in 482# etc.warn. 483# 484sub direct_syms 485{ 486 my ($filename) = @_; 487 # 488 # We stored the dynamic profile output in the app's output 489 # directory. This subroutine retrieves it, identifies the 490 # direct bindings symbol names and places them in a newline 491 # separated string returned to caller. 492 # 493 my $direct_syms = ''; 494 495 my $outfile = object_to_dir_name($filename); 496 $outfile = "$working_dir/$outfile/profile.dynamic"; 497 498 my $prof_fh = do { local *FH; *FH }; 499 if (! open($prof_fh, "<$outfile")) { 500 exiter(nofile($outfile, $!)); 501 } 502 my ($app, $caller, $lib, $sym); 503 while (<$prof_fh>) { 504 next if (/^\s*#/); 505 next if (/^\s*$/); 506 chop; 507 ($app, $caller, $lib, $sym) = split(/\|/, $_, 4); 508 next unless ($caller eq '*DIRECT*'); 509 $direct_syms .= "$sym\n"; 510 } 511 close($prof_fh); 512 513 return $direct_syms; 514} 515 516# 517# Block to keep export_list private 518# 519{ 520 my %export_list = ( 521 'AC_LIB_DIR', 'appcert_lib_dir', 522 'AC_WORKING_DIR', 'working_dir', 523 'AC_TMP_DIR', 'tmp_dir', 524 'AC_BINARY_COUNT', 'binary_count', 525 'AC_BLOCK_MIN', 'block_min', 526 'AC_BLOCK_MAX', 'block_max', 527 'AC_BATCH_REPORT', 'batch_report', 528 ); 529 530 531 # 532 # Subroutine to read in possibly exported variables 533 # 534 sub import_vars_from_environment 535 { 536 no strict qw(refs); 537 538 while (my ($evar, $pvar) = each(%export_list)) { 539 $pvar = $export_list{$evar}; 540 if (exists($ENV{$evar})) { 541 $$pvar = $ENV{$evar}; 542 } else { 543 $$pvar = ''; 544 } 545 } 546 } 547 548 # 549 # Exports the variables in %export_list to the environment. 550 # 551 sub export_vars_to_environment 552 { 553 my $pval; 554 no strict qw(refs); 555 556 while (my ($evar, $pvar) = each(%export_list)) { 557 $pvar = $export_list{$evar}; 558 $pval = $$pvar; 559 if (defined($pval)) { 560 $ENV{$evar} = $pval; 561 } 562 } 563 } 564} 565 566# 567# Routine for turning on or off LC_ALL environment variable 'C'. When 568# we want command output that we will parse we set LC_ALL=C. On the 569# other hand, when we want to pass command output to the user we retain 570# their locale (if any). 571# 572sub c_locale 573{ 574 my ($action) = @_; 575 576 # 577 # example usage: 578 # c_locale(1); 579 # $output = `some_cmd some_args 2>/dev/null`; 580 # c_locale(0); 581 # 582 583 if ($action) { 584 if (defined($ENV{'LC_ALL'})) { 585 $LC_ALL = $ENV{'LC_ALL'}; 586 } else { 587 $LC_ALL = '__UNSET__'; 588 } 589 $ENV{'LC_ALL'} = 'C'; 590 } else { 591 if ($LC_ALL eq '__UNSET__') { 592 delete $ENV{'LC_ALL'}; 593 } else { 594 $ENV{'LC_ALL'} = $LC_ALL; 595 } 596 } 597} 598 599# 600# Set or get the overall appcert result/return code. 601# 602sub overall_result_code 603{ 604 my ($val) = @_; 605 # 606 # The code has significance (see below) and is the numerical 607 # exit() code for the appcert script. 608 # 609 # Code can be number followed by 1-line description. 610 # 611 # 0 appcert completed OK and ZERO binaries had problems detected 612 # and ZERO binaries had "warnings". 613 # 1 appcert failed somehow 614 # 2 appcert completed OK and SOME binaries had problems detected. 615 # 3 appcert completed OK and ZERO binaries had problems detected. 616 # and SOME binaries had "warnings". 617 # 618 # When called with a no arguments, only the number is returned. 619 # When called with a non-null argument it is written to the rc file. 620 # 621 622 my ($return_code_file, $line); 623 624 $return_code_file = "$working_dir/ResultCode"; 625 626 my $rc_file_fh = do { local *FH; *FH }; 627 if (! defined($val)) { 628 if (! -f $return_code_file) { 629 emsg("%s", nofile($return_code_file)); 630 return 1; 631 } 632 open($rc_file_fh, "<$return_code_file") || 633 exiter(nofile($return_code_file, $!)); 634 chomp($line = <$rc_file_fh>); 635 close($rc_file_fh); 636 if ($line =~ /^(\d+)/) { 637 return $1; 638 } else { 639 return $line; 640 } 641 } else { 642 $val = trim($val); 643 if ($val !~ /^\d+/) { 644 $val = "1 $val"; 645 } 646 open($rc_file_fh, ">$return_code_file") || 647 exiter(nofile($return_code_file, $!)); 648 print $rc_file_fh $val, "\n"; 649 close($rc_file_fh); 650 return; 651 } 652} 653 654# 655# Sorter for strings like: "something 14", sorts on count (number) 656# first, then by string. 657# 658sub sort_on_count 659{ 660 my $soc_cmp = sub { 661 my($n1, $n2); 662 if ($a =~ /(\d+)\s*$/) { 663 $n1 = $1; 664 } else { 665 $n1 = 0; 666 } 667 if ($b =~ /(\d+)\s*$/) { 668 $n2 = $1; 669 } else { 670 $n2 = 0; 671 } 672 673 if ($n1 == $n2) { 674 # if the numbers are "tied", then compare the 675 # string portion. 676 $a cmp $b; 677 } else { 678 # otherwise compare numerically: 679 $n2 <=> $n1; 680 } 681 }; 682 return sort $soc_cmp @_; 683} 684 685# 686# Trims leading and trailing whitespace from a string. 687# 688sub trim 689{ 690 my ($x) = @_; 691 if (! defined($x)) { 692 return ''; 693 } 694 $x =~ s/^\s*//; 695 $x =~ s/\s*$//; 696 return $x; 697} 698 699# 700# Prints a line to filehandle or STDOUT. 701# 702sub print_line 703{ 704 my ($fh) = @_; 705 if (defined($fh)) { 706 print $fh '-' x 72, "\n"; 707 } else { 708 print STDOUT '-' x 72, "\n"; 709 } 710} 711 712# 713# Returns formatted output of list items that fit in 80 columns, e.g. 714# Gelf_got_title 1 Gelf_reloc_entry 1 715# Gelf_ver_def_print 1 Gelf_syminfo_entry_title 1 716# Gelf_sym_table_title 1 Gelf_elf_header 1 717# 718sub list_format 719{ 720 my ($indent, @list) = @_; 721 722 # $indent is a string which shifts everything over to the right. 723 724 my $width = 0; 725 my ($item, $len, $space); 726 727 foreach $item (@list) { # find the widest list item. 728 $len = length($item); 729 $width = $len if ($len > $width); 730 } 731 $width += 2; # pad 2 spaces for each column. 732 733 if ($width > (80 - length($indent))) { 734 $width = 80 - length($indent); 735 } 736 737 # compute number of columns: 738 my $columns = int((80 - length($indent))/$width); 739 740 # initialize: 741 my $current_column = 0; 742 my $text = $indent; 743 744 # put the items into lined up columns: 745 foreach $item (@list) { 746 if ($current_column >= $columns) { 747 $text .= "\n"; 748 $current_column = 0; 749 $text .= $indent; 750 } 751 $space = $width - length($item); 752 $text .= $item . ' ' x $space if ($space > 0); 753 $current_column++; 754 } 755 $text .= "\n" if ($current_column); 756 757 return $text; 758} 759 760# 761# Wrapper for STDERR messages. 762# 763sub emsg 764{ 765 printf STDERR @_; 766} 767 768# 769# Wrapper for STDOUT messages. 770# 771sub pmsg 772{ 773 printf STDOUT @_; 774} 775 776# 777# Error message for a failed file open. 778# 779sub nofile 780{ 781 my $msg = "$command_name: "; 782 $msg .= gettext("cannot open file: %s\n"); 783 $msg = sprintf($msg, join(' ', @_)); 784 785 return $msg; 786} 787 788# 789# Error message for an invalid file path. 790# 791sub nopathexist 792{ 793 my $msg = "$command_name: "; 794 $msg .= gettext("path does not exist: %s\n"); 795 $msg = sprintf($msg, join(' ', @_)); 796 797 return $msg; 798} 799 800# 801# Error message for a failed running of a command. 802# 803sub norunprog 804{ 805 my $msg = "$command_name: "; 806 $msg .= gettext("cannot run program: %s\n"); 807 $msg = sprintf($msg, join(' ', @_)); 808 809 return $msg; 810} 811 812# 813# Error message for a failed directory creation. 814# 815sub nocreatedir 816{ 817 my $msg = "$command_name: "; 818 $msg .= gettext("cannot create directory: %s\n"); 819 $msg = sprintf($msg, join(' ', @_)); 820 821 return $msg; 822} 823 824# 825# Error message for a failed directory opendir. 826# 827sub nodir 828{ 829 my $msg = "$command_name: "; 830 $msg .= gettext("cannot open directory: %s\n"); 831 $msg = sprintf($msg, join(' ', @_)); 832 833 return $msg; 834} 835 836# 837# exiter routine wrapper is used primarily to abort. Calls 838# clean_up_exit() routine if that routine is defined. Prints $msg to 839# STDERR and exits with exit code $status $status is 1 (aborted command) 840# by default. 841# 842sub exiter 843{ 844 my ($msg, $status) = @_; 845 846 if (defined($msg) && ! defined($status) && $msg =~ /^\d+$/) { 847 $status = $msg; 848 undef($msg); 849 } 850 if (! defined($status)) { 851 $status = 1; 852 } 853 854 if (defined($msg)) { 855 # 856 # append a newline unless one is already there or string 857 # is empty: 858 # 859 $msg .= "\n" unless ($msg eq '' || $msg =~ /\n$/); 860 emsg($msg); 861 } 862 if (defined($clean_up_exit_routine)) { 863 &$clean_up_exit_routine($status); 864 } 865 866 exit $status; 867} 868 869sub set_clean_up_exit_routine 870{ 871 my($code_ref) = @_; 872 $clean_up_exit_routine = $code_ref; 873} 874 875# 876# Generic routine for setting up signal handling. (usually just a clean 877# up and exit routine). 878# 879# Call with mode 'on' and the name of the handler subroutine. 880# Call with mode 'off' to set signal handling back to defaults 881# (e.g. a handler wants to call signals('off')). 882# Call it with 'ignore' to set them to ignore. 883# 884sub signals 885{ 886 my ($mode, $handler) = @_; 887 888 # List of general signals to handle: 889 my (@sigs) = qw(INT QUIT); 890 891 my $sig; 892 893 # Loop through signals and set the %SIG array accordingly. 894 895 if ($mode eq 'on') { 896 foreach $sig (@sigs) { 897 $SIG{$sig} = $handler; 898 } 899 } elsif ($mode eq 'off') { 900 foreach $sig (@sigs) { 901 $SIG{$sig} = 'DEFAULT'; 902 } 903 } elsif ($mode eq 'ignore') { 904 foreach $sig (@sigs) { 905 $SIG{$sig} = 'IGNORE'; 906 } 907 } 908} 909 910# 911# Creates a temporary directory with a unique name. Directory is 912# created and the directory name is return. On failure to create it, 913# null string is returned. 914# 915sub create_tmp_dir 916{ 917 my ($basedir) = @_; 918 # 919 # If passed a prefix in $prefix, try to create a unique tmp dir 920 # with that basedir. Otherwise, it will make a name in /tmp. 921 # 922 # If passed a directory that already exists, a subdir is created 923 # with madeup basename "prefix.suffix" 924 # 925 926 my $cmd = $command_name; 927 $cmd = 'tempdir' unless (defined($cmd) && $cmd ne ''); 928 929 if (! defined($basedir) || ! -d $basedir) { 930 $basedir = "/tmp/$cmd"; 931 } else { 932 $basedir = "$basedir/$cmd"; 933 } 934 935 my $suffix = $$; 936 if ($tmp_dir_count) { 937 $suffix .= ".$tmp_dir_count"; 938 } 939 my $dir = "$basedir.$suffix"; 940 $tmp_dir_count++; 941 if ($dir =~ m,^/tmp/,) { 942 if (! mkpath($dir, 0, 0700) || ! -d $dir) { 943 emsg("%s", nocreatedir($dir, $!)); 944 return ''; 945 } 946 } else { 947 if (! mkpath($dir) || ! -d $dir) { 948 emsg("%s", nocreatedir($dir, $!)); 949 return ''; 950 } 951 } 952 return $dir; 953} 954 955# 956# Checks to see if a directory is empty. Returns 1 if the directory is. 957# returns 0 if it is not or if directory does not exist. 958# 959sub dir_is_empty 960{ 961 my ($dir) = @_; 962 963 return 0 if (! -d $dir); 964 965 my $is_empty = 1; 966 967 my $dir_is_empty_dh = do { local *FH; *FH }; 968 if (opendir($dir_is_empty_dh, $dir)) { 969 my $subdir; 970 foreach $subdir (readdir($dir_is_empty_dh)) { 971 if ($subdir ne '.' && $subdir ne '..') { 972 $is_empty = 0; 973 last; 974 } 975 } 976 close($dir_is_empty_dh); 977 } else { 978 return 0; 979 } 980 981 return $is_empty; 982} 983 984# 985# Follows a symbolic link until it points to a non-symbolic link. If 986# $file is not a symlink but rather a file, returns $file. Returns null 987# if what is pointed to does not exist. 988# 989sub follow_symlink 990{ 991 my ($file) = @_; 992 993 if (! -e $file) { 994 # We will never find anything: 995 return ''; 996 } 997 998 if (! -l $file) { 999 # Not a symlink: 1000 return $file; 1001 } 1002 1003 my ($tmp1, $tmp2); 1004 1005 $tmp1 = $file; 1006 1007 while ($tmp2 = readlink($tmp1)) { 1008 1009 if ($tmp2 !~ m,^/,) { 1010 $tmp2 = dirname($tmp1) . "/" . $tmp2; 1011 } 1012 1013 $tmp1 = $tmp2; # 1014 $tmp1 =~ s,/+,/,g; # get rid of //// 1015 $tmp1 =~ s,^\./,,g; # remove leading ./ 1016 $tmp1 =~ s,/\./,/,g; # remove /./ 1017 $tmp1 =~ s,/+,/,g; # get rid of //// again 1018 $tmp1 =~ s,/[^/]+/\.\./,/,g; # remove "abc/.." 1019 # 1020 1021 if (! -e $tmp1) { 1022 $tmp1 = $tmp2; 1023 } 1024 if (! -e $tmp1) { 1025 return ''; 1026 } 1027 } 1028 1029 return $tmp1; 1030} 1031 1032# 1033# Examines if the file is statically linked. Can be called on any file, 1034# but it is preferable to run it on things known to be executables or 1035# libraries. 1036# 1037# Returns 0 if not statically linked. Otherwise, returns 1. 1038# 1039sub is_statically_linked 1040{ 1041 my ($file) = @_; 1042 1043 my $tmp; 1044 my $file_cmd_output; 1045 $file_cmd_output = cmd_output_file($file); 1046 1047 if ($file_cmd_output eq '') { 1048 return 1; 1049 } 1050 1051 if ($file_cmd_output =~ /[:\s](.*)$/) { 1052 $tmp = $1; 1053 if ($tmp =~ /ELF.*statically linked/) { 1054 return 1; 1055 } elsif ($tmp =~ /Sun demand paged/) { 1056 if ($tmp !~ /dynamically linked/) { 1057 return 1; 1058 } 1059 } 1060 } 1061 1062 return 0; 1063} 1064 1065# 1066# Examines first 4 bytes of file. Returns 1 if they are "\x7fELF". 1067# Otherwise, returns 0. 1068# 1069sub is_elf 1070{ 1071 my ($file) = @_; 1072 1073 my ($buf, $n); 1074 my $cmp = "\x7fELF"; 1075 if (! -r $file) { 1076 return 0; 1077 } 1078 1079 my $is_elf_fh = do { local *FH; *FH }; 1080 if (open($is_elf_fh, "<$file")) { 1081 $n = read($is_elf_fh, $buf, 4); 1082 close($is_elf_fh); 1083 if ($n != 4) { 1084 return 0; 1085 } 1086 if ($buf eq $cmp) { 1087 return 1; 1088 } 1089 } 1090 return 0; 1091} 1092 1093# 1094# Returns 1 if $file is a shared object (i.e. ELF shared library) 1095# Returns 0 if it is not. 1096# 1097# Routine uses the dump -Lv output to determine this. Failing that, it 1098# examines the file(1) output. 1099# 1100sub is_shared_object 1101{ 1102 my ($file) = @_; 1103 1104 return 0 unless (-f $file); 1105 1106 my ($on, $line, $is_shared_object); 1107 my ($n, $tag, $val); 1108 1109 $on = 0; 1110 $is_shared_object = 0; 1111 1112 foreach $line (split(/\n/, cmd_output_dump($file))) { 1113 1114 if ($line =~ /^\[INDEX\]/) { 1115 $on = 1; 1116 next; 1117 } 1118 next unless ($on); 1119 ($n, $tag, $val) = split(/\s+/, trim($line)); 1120 if ($tag eq "SONAME") { 1121 $is_shared_object = 1; 1122 last; 1123 } 1124 } 1125 1126 if (! $is_shared_object) { 1127 # If it is ELF, file output will say "dynamic lib": 1128 $line = cmd_output_file($file); 1129 if ($line =~ /ELF.* dynamic lib /) { 1130 $is_shared_object = 1; 1131 } 1132 } 1133 1134 return $is_shared_object; 1135} 1136 1137# 1138# Used for the a.out warning in etc.warn. Examines first 4 bytes of 1139# file, and returns 1 if SunOS 4.x a.out binary 0 otherwise. 1140# 1141sub is_aout 1142{ 1143 my ($file) = @_; 1144 1145 my ($buf, $n); 1146 my $cmp1 = "\001\013"; 1147 my $cmp2 = "\001\010"; 1148 my $cmp3 = "\001\007"; 1149 if (! -r $file) { 1150 return 0; 1151 } 1152 1153 my $is_aout_fh = do { local *FH; *FH }; 1154 if (open($is_aout_fh, "<$file")) { 1155 $n = read($is_aout_fh, $buf, 4); 1156 close($is_aout_fh); 1157 if ($n != 4) { 1158 return 0; 1159 } 1160 $buf = substr($buf, 2); 1161 if ($buf eq $cmp1) { 1162 return 1; 1163 } 1164 if ($buf eq $cmp2) { 1165 return 1; 1166 } 1167 if ($buf eq $cmp3) { 1168 return 1; 1169 } 1170 } 1171 return 0; 1172} 1173 1174# 1175# is_suid 1176# Returns 1 if $file is a set user ID file. 1177# Returns 2 if $file otherwise is a set group ID (but not suid). 1178# Returns 0 if it is neither or file does not exist. 1179# 1180sub is_suid 1181{ 1182 my ($file) = @_; 1183 1184 return 0 unless (-f $file); 1185 1186 my ($mask, $mode, $test); 1187 my @is_suid_masks = (04000, 02010, 02030, 02050, 02070); 1188 1189 $mode = (stat($file))[2]; 1190 1191 foreach $mask (@is_suid_masks) { 1192 $test = $mode & $mask; 1193 if ($test == $mask) { 1194 if ($mask == $is_suid_masks[0]) { 1195 return 1; 1196 } else { 1197 return 2; 1198 } 1199 } 1200 } 1201 return 0; 1202} 1203 1204# 1205# Returns a list of (abi, [ELF|a.out], wordsize, endianness) 1206# 1207sub bin_type 1208{ 1209 my ($filename) = @_; 1210 1211 my ($abi, $e_machine, $type, $wordsize, $endian, $rest); 1212 1213 $abi = 'unknown'; 1214 $e_machine = 'unknown'; 1215 $type = 'unknown'; 1216 $wordsize = 'unknown'; 1217 $endian = 'unknown'; 1218 1219 # Try to look it up in the $working_dir: 1220 my $outfile = object_to_dir_name($filename); 1221 $outfile = "$working_dir/$outfile/info.arch"; 1222 1223 if (-f $outfile) { 1224 my $arch_info_fh = do { local *FH; *FH }; 1225 if (open($arch_info_fh, "<$outfile")) { 1226 while (<$arch_info_fh>) { 1227 chomp; 1228 if (/^ARCH:\s*(\S.*)$/) { 1229 $abi = $1; 1230 } elsif (/^TYPE:\s*(\S.*)$/) { 1231 $type = $1; 1232 } elsif (/^WORDSIZE:\s*(\S.*)$/) { 1233 $wordsize = $1; 1234 } elsif (/^BYTEORDER:\s*(\S.*)$/) { 1235 $endian = $1; 1236 } 1237 } 1238 close($arch_info_fh); 1239 } 1240 return ($abi, $type, $wordsize, $endian); 1241 } 1242 1243 # Otherwise, process file(1) output: 1244 my $file_output; 1245 $file_output = cmd_output_file($filename); 1246 1247 if ($file_output =~ /Sun demand paged SPARC|pure SPARC/) { 1248 $type = 'a.out'; 1249 $abi = 'sparc'; 1250 $e_machine = 'SPARC'; 1251 $wordsize = '32'; 1252 $endian = 'MSB'; 1253 } elsif ($file_output =~ /ELF\s+/) { 1254 $type = 'ELF'; 1255 $rest = $'; 1256 if ($rest =~ /^(\d+)-bit\s+/) { 1257 $wordsize = $1; 1258 $rest = $'; 1259 } 1260 if ($rest =~ /^(LSB|MSB)\s+/) { 1261 $endian = $1; 1262 $rest = $'; 1263 } 1264 if ($rest =~ /SPARC/) { 1265 if ($rest =~ /\bSPARC\b/) { 1266 $abi = 'sparc'; 1267 $e_machine = 'SPARC'; 1268 } elsif ($rest =~ /\bSPARC32PLUS\b/) { 1269 $abi = 'sparc'; 1270 $e_machine = 'SPARC32PLUS'; 1271 } elsif ($rest =~ /\bSPARCV9\b/) { 1272 $abi = 'sparcv9'; 1273 $e_machine = 'SPARCV9'; 1274 } 1275 } else { 1276 if ($rest =~ /\bAMD64\b/ || 1277 $wordsize == 64 && $endian eq 'LSB') { 1278 $abi = 'amd64'; 1279 $e_machine = 'AMD64'; 1280 } elsif ($rest =~ /\b80386\b/) { 1281 $abi = 'i386'; 1282 $e_machine = '80386'; 1283 } 1284 } 1285 } 1286 return ($abi, $type, $wordsize, $endian, $e_machine); 1287} 1288 1289# 1290# Compares two files to see if they are the same. First tries some 1291# string comparisons. Then, if $fast is not true, attempts an inode 1292# comparison. 1293# 1294sub files_equal 1295{ 1296 my ($file1, $file2, $fast) = @_; 1297 1298 my ($f1, $f2); 1299 1300 # 1301 # If they are the same string, we say they are equal without 1302 # checking if they do exist. 1303 # 1304 1305 if ($file1 eq $file2) { 1306 return 1; 1307 } 1308 1309 # Try trimming off any leading "./" 1310 $f1 = $file1; 1311 $f2 = $file2; 1312 1313 $f1 =~ s,^\./+,,; 1314 $f2 =~ s,^\./+,,; 1315 1316 if ($f1 eq $f2) { 1317 return 1; 1318 } 1319 1320 # That is all we do if doing a fast compare. 1321 return 0 if ($fast); 1322 1323 # Otherwise, resort to the file system: 1324 1325 my ($inode1, $inode2); 1326 $inode1 = file_inode($file1); 1327 $inode2 = file_inode($file2); 1328 1329 if (! defined($inode1) || ! defined($inode2) || 1330 $inode1 < 0 || $inode2 < 0) { 1331 return 0; 1332 } elsif ($inode1 eq $inode2) { 1333 return 1; 1334 } 1335 return 0; 1336} 1337 1338# 1339# Utility to return the inode of a file. Used to determine if two 1340# different paths or a path + symlink point to the same actual file. 1341# 1342sub file_inode 1343{ 1344 my ($file) = @_; 1345 1346 my $inode; 1347 if (exists($file_inode_cache{$file})) { 1348 return $file_inode_cache{$file}; 1349 } 1350 1351 if (! file_exists($file)) { 1352 $file_inode_cache{$file} = -1; 1353 return -1; 1354 } 1355 1356 $inode = (stat($file))[1]; 1357 1358 if (! defined($inode) || $inode !~ /^\d+$/) { 1359 $inode = -1; 1360 } 1361 1362 $file_inode_cache{$file} = $inode; 1363 return $inode; 1364} 1365 1366# 1367# Existence test for files. Caches the results for speed. 1368# 1369sub file_exists 1370{ 1371 my ($file) = @_; 1372 1373 if (exists($file_exists_cache{$file})) { 1374 return $file_exists_cache{$file}; 1375 } 1376 1377 my $x; 1378 if (-e $file) { 1379 $x = 1; 1380 } else { 1381 $x = 0; 1382 } 1383 $file_exists_cache{$file} = $x; 1384 1385 return $x; 1386} 1387 1388# 1389# This routine deletes the caches we store information (e.g. cmd output) 1390# in to improve performance. It is called when the caches are suspected 1391# to be too large. 1392# 1393sub purge_caches 1394{ 1395 undef %file_exists_cache; 1396 undef %file_inode_cache; 1397 undef %filter_lib_cache; 1398 undef %cmd_output_file_cache; 1399 undef %cmd_output_dump_cache; 1400 undef %all_ldd_neededs_cache; 1401} 1402 1403# 1404# Given a filter library, this routine tries to determine if it is a 1405# STANDARD filter or an AUXILIARY filter. This is done by running dump 1406# -Lv on the filter library. Results are cached in the global 1407# filter_lib_cache to avoid calling dump many times on the same library 1408# (e.g. libc.so.1). 1409# 1410sub filter_lib_type 1411{ 1412 my ($filter) = @_; 1413 1414 my $type = 'unknown'; 1415 1416 if (exists($filter_lib_cache{$filter})) { 1417 return $filter_lib_cache{$filter}; 1418 } 1419 1420 if (! -f $filter) { 1421 $filter_lib_cache{$filter} = 'unknown'; 1422 return 'unknown'; 1423 } 1424 1425 my $dump_output; 1426 $dump_output = cmd_output_dump($filter); 1427 1428 if (! $dump_output) { 1429 emsg(gettext("could not determine library filter type: %s\n"), 1430 $filter); 1431 $filter_lib_cache{$filter} = 'unknown'; 1432 1433 } else { 1434 my ($line, $dump, $idx, $tag, $val); 1435 my ($saw_filter, $saw_aux); 1436 $saw_filter = 0; 1437 $saw_aux = 0; 1438 foreach $line (split(/\n/, $dump_output)) { 1439 next unless ($line =~ /^\[\d+\]/); 1440 $dump = trim($line); 1441 ($idx, $tag, $val) = split(/\s+/, $dump); 1442 # detect both names used for each filter type: 1443 if ($tag eq 'FILTER' || $tag eq 'SUNW_FILTER') { 1444 $type = 'STD'; 1445 $saw_filter = 1; 1446 } elsif ($tag eq 'AUXILIARY' || $tag eq 1447 'SUNW_AUXILIARY') { 1448 $type = 'AUX'; 1449 $saw_aux = 1; 1450 } 1451 } 1452 if ($saw_filter && $saw_aux) { 1453 $type = 'AUX'; 1454 } 1455 $filter_lib_cache{$filter} = $type; 1456 } 1457 return $filter_lib_cache{$filter}; 1458} 1459 1460# 1461# Calls "abi_index" to dynamically create the list of Solaris libraries 1462# and their characteristics. 1463# 1464sub load_model_index 1465{ 1466 my $dir = "auto"; # all model indexes are created automatically 1467 1468 if (exists($lib_index_loaded{$dir})) { 1469 if ($lib_index_loaded{$dir} == -1) { 1470 return 0; 1471 } else { 1472 return 1; 1473 } 1474 } 1475 1476 my ($lib, $lib2, $def, $cnt, $link_cnt, $all_links); 1477 my ($key, $base); 1478 1479 my $reading_cache_file; 1480 1481 $link_cnt = 0; 1482 my $cache_file = "$working_dir/AbiIndex"; 1483 my $index_fh = do { local *FH; *FH }; 1484 my $cache_fh = do { local *FH; *FH }; 1485 if (-f $cache_file) { 1486 open($index_fh, "<$cache_file") || 1487 exiter(nofile($cache_file, $!)); 1488 $reading_cache_file = 1; 1489 } else { 1490 if (! open($index_fh, 1491 "$appcert_lib_dir/abi_index 2>/dev/null |")) { 1492 exiter(noprogrun("abi_index", $!)); 1493 } 1494 if (! open($cache_fh, ">$cache_file")) { 1495 exiter(nofile($cache_file, $!)); 1496 } 1497 $reading_cache_file = 0; 1498 } 1499 1500 if (! $reading_cache_file) { 1501 emsg("\n"); 1502 emsg(gettext("determining list of Solaris libraries")); 1503 emsg(" ...\n"); 1504 } 1505 1506 my $abi; 1507 while (<$index_fh>) { 1508 next if (/^\s*#/); 1509 next if (/^\s*$/); 1510 print $cache_fh $_ if (! $reading_cache_file); 1511 chomp; 1512 1513 ($abi, $lib, $def, $cnt, $all_links) = split(/\|/, $_, 5); 1514 1515 next if (! -f $lib); 1516 1517 $abi = 'any' if ($abi eq 'unknown'); 1518 1519 # note if $all_links is empty, we still get the base lib. 1520 foreach $lib2 ($lib, split(/:/, $all_links)) { 1521 $key = "$dir|$lib2|$abi"; 1522 $lib_index_definition{$key} = $def; 1523 1524 $base = basename($lib2); 1525 # 1526 # store an index of lib basenames to be used for 1527 # libfoo.so* matching. 1528 # 1529 $shared_object_index{$base}++; 1530 $lib_index{$base}++ if ($base =~ /^lib/); 1531 1532 $link_cnt++; 1533 } 1534 # 1535 # record the device/inode too, used to avoid confusion due 1536 # to symlinks between *directories* instead of files. E.g.: 1537 # /usr/lib/64 -> /usr/lib/sparcv9 1538 # under some crle(1) configurations this can be 1539 # particularly problematic. 1540 # 1541 if (-e $lib) { 1542 my ($device, $inode) = (stat($lib))[0,1]; 1543 if (defined($device) && defined($inode)) { 1544 $key = "$dir|$device/$inode|$abi"; 1545 $lib_index_definition{$key} = $def; 1546 } 1547 } 1548 } 1549 close($index_fh); 1550 close($cache_fh) if (! $reading_cache_file); 1551 1552 # return 1 if library links were loaded. 0 indicates a failure. 1553 push(@lib_index_loaded, $dir); 1554 if ($link_cnt) { 1555 $lib_index_loaded{$dir} = $link_cnt; 1556 return 1; 1557 } else { 1558 $lib_index_loaded{$dir} = -1; 1559 return 0; 1560 } 1561} 1562 1563# 1564# Returns a list of Solaris library basenames matching a pattern. If a 1565# directory name is in $pattern, it will be prepended to each item. 1566# 1567sub lib_match 1568{ 1569 my ($pattern, $return_something) = @_; 1570 1571 if ($pattern eq '*') { 1572 # special case '*' 1573 return $pattern; 1574 } 1575 1576 # 1577 # $return_something = 1 means if there was nothing matched, 1578 # return $pattern to the caller. 1579 # 1580 # This sub should only be called to initialize things since it 1581 # is very slow. (runs the regex over all libraries) Do not call 1582 # it in a loop over, say, application binaries. Rather, call it 1583 # before the loop and make note of all the discrete cases. 1584 # 1585 1586 # To handle libfoo.so* matching, we need the Index file loaded: 1587 if (! $lib_match_initialized) { 1588 load_model_index(); 1589 $lib_match_initialized = 1; 1590 } 1591 1592 my (@list, @libs, $lib, $id, $patt0, $dir0); 1593 1594 # if empty, set it to "0" for the $id key. 1595 $return_something = 0 if ($return_something eq ''); 1596 $id = "$pattern|$return_something"; 1597 1598 if (defined($lib_match_cache{$id})) { 1599 # If we have already found it, return the cached result. 1600 return split(/\|/, $lib_match_cache{$id}); 1601 } 1602 1603 $patt0 = $pattern; 1604 # extract dirname, if any. 1605 if ($pattern =~ m,/,) { 1606 $dir0 = dirname($pattern); 1607 $pattern = basename($pattern); 1608 } else { 1609 $dir0 = ''; 1610 } 1611 1612 # turn the matching pattern into a regex: 1613 $pattern =~ s/\./\\./g; # protect .'s 1614 $pattern =~ s/\*/.*/g; # * -> .* 1615 $pattern =~ s,/,\\/,g; # protect /'s (see below) 1616 1617 # 1618 # create a little code to check the match, since there will be a 1619 # big loop of checks: note the anchoring /^...$/ 1620 # 1621 my $regex = qr/^$pattern$/; 1622 1623 if ($pattern =~ /^lib/) { 1624 # for a bit of speed, the lib* set is much smaller, so use it: 1625 @libs = keys(%lib_index); 1626 } else { 1627 # this is the full list: 1628 @libs = keys(%shared_object_index); 1629 } 1630 1631 # now try all libs for a match, and store in @list. 1632 foreach $lib (@libs) { 1633 if ($lib =~ /$regex/) { 1634 if ($dir0 ne '') { 1635 # put back the dirname: 1636 $lib = "$dir0/$lib"; 1637 } 1638 push(@list, $lib); 1639 } 1640 } 1641 1642 # return list and cache result: 1643 if ($return_something && ! @list) { 1644 $lib_match_cache{$id} = $patt0; 1645 return $patt0; 1646 } else { 1647 $lib_match_cache{$id} = join('|', @list); 1648 return @list; 1649 } 1650} 1651 1652# 1653# Expand the matches in a etc.warn MATCH expression. 1654# returns subroutine code for the comparison. 1655# 1656sub expand_expr 1657{ 1658 my($expr) = @_; 1659 my $code = 'my($fn) = @_; '; 1660 $expr =~ s/\bfile\s*\=\~\s*/ cmd_output_file(\$fn) =~ /g; 1661 $expr =~ s/\bdump\s*\=\~\s*/ cmd_output_dump(\$fn) =~ /g; 1662 $expr =~ s/\bneeded\s*\=\~\s*/ all_ldd_neededs_string(\$fn) =~ /g; 1663 $expr =~ s/\bsyms\s*\=\~\s*/ direct_syms(\$fn) =~ /g; 1664 1665 $code .= "if ($expr) {return 1;} else {return 0;}"; 1666 return $code; 1667} 1668 1669# 1670# Loads the binary stability information contained in the 1671# /usr/lib/abi/appcert/etc.* files. 1672# 1673sub load_misc_check_databases 1674{ 1675 my $etc_dir = "$appcert_lib_dir"; 1676 1677 my ($etc_file, $line); 1678 1679 my (@etcs) = <$etc_dir/etc.*>; 1680 1681 # 1682 # Event(etc.) types to handle: 1683 # 1684 # SCOPED_SYMBOL|<release>|<lib>|<sym> 1685 # MODEL_TWEAK|<library>|<abi1,...>|<symbol>|<classification> 1686 # REMOVED_SYMBOL|<release>|<lib>|<sym> 1687 # 1688 1689 my ($tag, $rel, $lib, $sym, $rest); 1690 my ($abis, $class, $tmp, $gather); 1691 1692 # Read in and process all the etc files: 1693 my $count = 0; 1694 foreach $etc_file (@etcs) { 1695 my $etc_fh = do { local *FH; *FH }; 1696 if (! open($etc_fh, "<$etc_file")) { 1697 exiter(nofile($etc_file, $!)); 1698 } 1699 while (<$etc_fh>) { 1700 # read each line: 1701 chomp($line = $_); 1702 1703 # gather lines continued with "\" at end: 1704 while ($line =~ /\\$/) { 1705 chomp($line); 1706 last if (eof($etc_fh)); 1707 chomp($tmp = <$etc_fh>); 1708 # handle "-" ... "-" style text blocks. 1709 if ($tmp eq '-') { 1710 # 1711 # gather everything until the 1712 # next '-' line. 1713 # 1714 $gather = ''; 1715 while (1) { 1716 last if (eof($etc_fh)); 1717 chomp($tmp = <$etc_fh>); 1718 last if ($tmp eq '-'); 1719 $gather .= "|$tmp"; 1720 } 1721 $line .= $gather; 1722 } else { 1723 $line .= " " . $tmp; 1724 } 1725 } 1726 1727 # 1728 # skip blank lines or lines (including continued lines) 1729 # beginning with "#" 1730 # 1731 next if ($line =~ /^\s*#/); 1732 next if ($line =~ /^\s*$/); 1733 1734 my $lib2; 1735 1736 # Case statement for all the types: 1737 if ($line =~ /^SCOPED_SYMBOL/) { 1738 ($tag, $rel, $lib, $sym, $rest) = 1739 split(/\|/, $line, 5); 1740 # 1741 # current implementation uses library basename. 1742 # 1743 # We may also want to split this value 1744 # into a hash or two, e.g. 1745 # Scope_Symbol_Release, etc.. 1746 # 1747 # No lib_match wild-carding done for this case. 1748 # 1749 $scoped_symbol{"$lib|$sym"} .= 1750 "$rel|$lib|$sym,"; 1751 $scoped_symbol_all{"$sym"} .= 1752 "$rel|$lib|$sym,"; 1753 } elsif ($line =~ /^SKIP_SYMBOL/) { 1754 # 1755 # These are low-level, e.g. C runtime 1756 # we always want to skip. 1757 # 1758 ($tag, $sym) = split(/\|/, $line, 2); 1759 $skip_symbols{$sym} = 1; 1760 1761 } elsif ($line =~ /^MODEL_TWEAK/) { 1762 # 1763 # These are direct edits of symbol 1764 # public/private database. 1765 # 1766 ($tag, $lib, $abis, $sym, $class) = 1767 split(/\|/, $line, 5); 1768 # change arch sep from "," to "%" 1769 $abis =~ s/,/%/g; 1770 1771 my (@libs, $lib64, @tmp); 1772 if ($lib =~ /\*/) { 1773 @libs = lib_match($lib, 1); 1774 } else { 1775 push(@libs, $lib); 1776 } 1777 if ($abis eq '*') { 1778 # 1779 # '*' means all ABIs, so we modify 1780 # pathnames to reflect the 64 bit 1781 # versions. If these exists on the 1782 # system, we append them to the list 1783 # for this tweak. 1784 # 1785 @tmp = @libs; 1786 foreach $lib2 (@tmp) { 1787 if ($lib2 !~ m,/lib/,) { 1788 next; 1789 } 1790 # 1791 # check for existence of sparc 1792 # and x86 64 bit versions. 1793 # 1794 $lib64 = $lib2; 1795 $lib64 =~ 1796 s,/lib/,/lib/sparcv9/,; 1797 if (-e $lib64) { 1798 push(@libs, $lib64); 1799 } 1800 $lib64 = $lib2; 1801 $lib64 =~ s,/lib/,/lib/amd64/,; 1802 if (-e $lib64) { 1803 push(@libs, $lib64); 1804 } 1805 $lib64 = $lib2; 1806 $lib64 =~ s,/lib/,/lib/64/,; 1807 if (-e $lib64) { 1808 push(@libs, $lib64); 1809 } 1810 } 1811 } 1812 1813 @tmp = @libs; 1814 foreach $lib2 (@tmp) { 1815 if ($lib2 !~ m,/, || ! -e $lib2) { 1816 next; 1817 } 1818 # 1819 # if it exists on the system, 1820 # store info wrt inode as well: 1821 # 1822 my ($device, $inode); 1823 ($device, $inode) = (stat($lib2))[0,1]; 1824 if ($device ne '' && $inode ne '') { 1825 push(@libs, "$device/$inode"); 1826 } 1827 } 1828 1829 # 1830 # now store the tweak info for all associated 1831 # libraries. 1832 # 1833 foreach $lib2 (@libs) { 1834 $model_tweak{$lib2} .= 1835 "$sym|$abis|$class,"; 1836 } 1837 1838 } elsif ($line =~ /^WARNING:/) { 1839 # 1840 # Extra warnings for miscellaneous problems. 1841 # 1842 my $cnt = 0; 1843 my ($warn, $tag, $desc, $bindings); 1844 my ($bind, $text); 1845 ($warn, $tag, $desc, $bindings, $text) = 1846 split(/:/, $line, 5); 1847 1848 # trim any leading spaces: 1849 $tag =~ s/^\s*//; 1850 $desc =~ s/^\s*//; 1851 $bindings =~ s/^\s*//; 1852 $text =~ s/^\s*//; 1853 1854 $tag =~ s,[\s/;]+,_,g; 1855 1856 # 1857 # desc lists will be ";" delimited, so 1858 # replace any found in the text. 1859 # 1860 $desc =~ s/;/,/g; 1861 $desc = trim($desc); 1862 1863 1864 # Store info in %Warnings_* hashes: 1865 1866 $warnings_desc{$tag} = $desc; 1867 1868 $warnings_match{$tag} = ''; 1869 1870 if ($bindings =~ /^MATCH\s*(\S.*)$/) { 1871 # 1872 # Handle the pattern MATCH 1873 # case. Note there there is no 1874 # libfoo.so.* matching here. 1875 # 1876 my $expr = $1; 1877 my $code; 1878 1879 # 1880 # For efficiency we will create 1881 # a subroutine for each case. 1882 # 1883 1884 # get subref code: 1885 $code = expand_expr($expr); 1886 1887 # define the subroutine: 1888 1889 my $subref; 1890 eval "\$subref = sub { $code };"; 1891 if ("$@" eq "" && $subref) { 1892 $warnings_match{$tag} = $subref; 1893 } 1894 } else { 1895 # 1896 # Otherwise, it is a 1897 # lib|sym|caller type match 1898 # 1899 my ($lib, $sym, $rest); 1900 foreach $bind (split(/,/, $bindings)) { 1901 # 1902 # Create pseudo tag, 1903 # "tag|N", for each 1904 # binding. 1905 # 1906 $bind = trim($bind); 1907 ($lib, $sym, $rest) = 1908 split(/\|/, $bind, 3); 1909 foreach $lib2 1910 (lib_match($lib, 1)) { 1911 $tmp = "$tag|$cnt"; 1912 $warnings_bind{$tmp} = 1913 "$lib2|$sym|$rest"; 1914 $warnings_desc{$tmp} = 1915 $desc; 1916 $cnt++; 1917 } 1918 } 1919 } 1920 } 1921 } 1922 $count++; 1923 close($etc_fh); 1924 } 1925 1926 # Trim any trailing "," separators from the last append: 1927 1928 my $key; 1929 foreach $key (keys(%scoped_symbol)) { 1930 $scoped_symbol{$key} =~ s/,+$//; 1931 } 1932 foreach $key (keys(%scoped_symbol_all)) { 1933 $scoped_symbol_all{$key} =~ s/,+$//; 1934 } 1935 foreach $key (keys(%model_tweak)) { 1936 $model_tweak{$key} =~ s/,+$//; 1937 # 1938 # make sure tweak is associated with device/inode to aid not 1939 # getting tricked by symlinks under crle, LD_LIBRARY_PATH, etc. 1940 # 1941 my ($device, $inode) = (stat($key))[0,1]; 1942 if (defined($device) && defined($inode)) { 1943 $model_tweak{"$device/$inode"} = $model_tweak{$key}; 1944 } 1945 } 1946 return $count; 1947} 1948 19491; 1950