xref: /illumos-gate/usr/src/cmd/abi/appcert/scripts/AppcertUtil.pm (revision 4e6271a8389d5230e559fd147b6812f9b6122ff4)
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