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