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