8322 nl: misleading-indentation
[unleashed/tickless.git] / usr / src / tools / scripts / interface_cmp.pl
blob9e40410c4d697e05cfea98f6b40f8746f7acb0d8
1 #!/usr/bin/perl -w
3 # CDDL HEADER START
5 # The contents of this file are subject to the terms of the
6 # Common Development and Distribution License (the "License").
7 # You may not use this file except in compliance with the License.
9 # You can obtain a copy of the license at usr/src/OPENSOLARIS.LICENSE
10 # or http://www.opensolaris.org/os/licensing.
11 # See the License for the specific language governing permissions
12 # and limitations under the License.
14 # When distributing Covered Code, include this CDDL HEADER in each
15 # file and include the License file at usr/src/OPENSOLARIS.LICENSE.
16 # If applicable, add the following below this CDDL HEADER, with the
17 # fields enclosed by brackets "[]" replaced with your own identifying
18 # information: Portions Copyright [yyyy] [name of copyright owner]
20 # CDDL HEADER END
24 # Copyright (c) 2009, 2010, Oracle and/or its affiliates. All rights reserved.
28 # interface_cmp audits two interface definition files (as created by
29 # interface_check) against one another, and confirms that:
31 # o All versioned libraries that were present in the previous interface
32 # are present in the new interface
34 # o for each non-private interface in a library confirm that no symbols
35 # have been removed and that no symbols have been added to it between
36 # the two revisions
38 # Return codes:
40 # 0 All interfaces in the new release are identical in old release.
41 # 1 Something is different refer to the error messages.
44 use strict;
46 use POSIX qw(getenv);
47 use Getopt::Std;
48 use File::Basename;
50 #### Define all global variables (required for strict)
51 use vars qw($Prog);
52 use vars qw(%opt);
53 use vars qw(%old_hash %old_alias %new_hash %new_alias);
55 # Exception Arrays:
57 # The ADDSYM and DELSYM exceptions are maintained on the @AddSymList
58 # and @DelSymList arrays, respectively. Each array element is a reference
59 # to a subarray of triples:
60 # (sym_re, ver_re, obj_re)
61 # where each item in the tripple is a regular expression, used to
62 # match a particular symbol/version/object combination.
64 # The EMPTY_TOPVERSION exceptions are maintained on the @EmptyTopVerList
65 # array. Each array element is a reference to a subarray of pairs:
66 # (ver_re, obj_re)
67 # where each item in the pair is a regular expression, used to
68 # match a particular version/object combination.
70 use vars qw(@AddSymList @DelSymList @EmptyTopVerList);
73 ## LoadExceptions
75 # Locate the exceptions file and process its contents. We can't use
76 # onbld_elfmod::LoadExceptionsToEXRE() for this, because our exceptions
77 # need to support more than a single regular expression.
79 # exit:
80 # @AddSymList, @DelSymList, and @EmptyTopVerList have been updated
82 # note:
83 # We expand strings of the form MACH(dir) to match the given
84 # directory as well as any 64-bit architecture subdirectory that
85 # might be present (i.e. amd64, sparcv9).
87 sub LoadExceptions {
88 my $file;
89 my $Line;
90 my $LineNum = 0;
91 my $err = 0;
93 # Locate the exception file
94 FILE: {
95 # If -e is specified, that file must be used
96 if ($opt{e}) {
97 $file = $opt{e};
98 last FILE;
101 # If this is an activated workspace, use the exception
102 # file found in the exceptions_list directory.
103 if (defined($ENV{CODEMGR_WS})) {
104 $file = "$ENV{CODEMGR_WS}/exception_lists/interface_cmp";
105 last FILE if (-f $file);
108 # As a final backstop, the SUNWonbld package provides a
109 # copy of the exception file. This can be useful if we
110 # are being used with an older workspace.
112 # This script is installed in the SUNWonbld bin directory,
113 # while the exception file is in etc/exception_lists. Find
114 # it relative to the script location given by $0.
115 $file = dirname($0) . "/../etc/exception_lists/interface_cmp";
116 last FILE if (-f $file);
118 # No exception file was found.
119 return;
122 open (EFILE, $file) ||
123 die "$Prog: unable to open exceptions file: $file";
124 while ($Line = onbld_elfmod::GetLine(\*EFILE, \$LineNum)) {
126 # Expand MACH()
127 $Line =~ s/MACH\(([^)]+)\)/$1(\/amd64|\/sparcv9)?/g;
129 if ($Line =~ /^DELSYM\s+/) {
130 my ($item, $sym_re, $ver_re, $obj_re) =
131 split(/\s+/, $Line, 4);
132 push @DelSymList, [ $sym_re, $ver_re, $obj_re ];
133 next;
136 if ($Line =~ /^ADDSYM\s+/) {
137 my ($item, $sym_re, $ver_re, $obj_re) =
138 split(/\s+/, $Line, 4);
139 push @AddSymList, [ $sym_re, $ver_re, $obj_re ];
140 next;
143 if ($Line =~ /^EMPTY_TOPVERSION\s+/) {
144 my ($item, $ver_re, $obj_re) = split(/\s+/, $Line, 3);
145 push @EmptyTopVerList, [ $ver_re, $obj_re ];
146 next;
149 $err++;
150 printf(STDERR "$file: Unrecognized option: ".
151 "line $LineNum: $Line\n");
153 close EFILE;
155 exit 1 if ($err != 0);
158 ## ExSym(SymList, sym, ver, obj)
160 # Compare a given symbol/version/object combination against the
161 # exceptions found in the given list.
163 # entry:
164 # SymList - Reference to @AddSymList, or @DelSymList.
165 # sym, ver, obj - Combination to be compared against exception list
167 # exit:
168 # Returns True (1) if there is a match, and False (0) otherwise.
170 sub ExSym {
171 my ($SymList, $sym, $ver, $obj) = @_;
173 foreach my $ex (@$SymList) {
174 return 1 if ($obj =~ /$$ex[2]/) && ($ver =~ /$$ex[1]/) &&
175 ($sym =~ /$$ex[0]/);
178 return 0;
181 ## ExTopVer(ver, obj)
183 # Compare a given version/object combination against the pairs found
184 # in @EmptyTopVerList.
186 # entry:
187 # ver, obj - Combination to be compared against empty top version list
189 # exit:
190 # Returns True (1) if there is a match, and False (0) otherwise.
192 sub ExTopVer {
193 my ($ver, $obj) = @_;
195 foreach my $ex (@EmptyTopVerList) {
196 return 1 if ($obj =~ /$$ex[1]/) && ($ver =~ /$$ex[0]/);
199 return 0;
202 ## ExpandInheritance(objhashref)
204 # For each version contained in the specified object hash reference,
205 # add the inherited symbols.
207 sub ExpandInheritance {
208 my $obj = $_[0];
210 # Versions to process. Typically, inheriting versions come before
211 # the versions they inherit. Processing the list in reverse order
212 # maximizes the odds that a needed sub-version will have already
213 # have been processed.
214 my @vers = reverse(@{$obj->{'VERSION_NAMES'}});
216 # Versions to process in the next pass
217 my @next_vers = ();
219 # Hash, indexed by version name, that reflects whether the version
220 # has been expanded yet or not.
221 my %done = ();
223 while (scalar(@vers) > 0) {
224 foreach my $name (@vers) {
225 my $i;
226 my $defer = 0;
227 my $cur_version = $obj->{'VERSION_INFO'}{$name};
228 my ($top, $direct, $total, $symhash, $inheritarr) =
229 @{$cur_version};
231 # In order to expand this version, all the inherited
232 # versions must already have been done. If not, put
233 # this version on @next_vers for the next pass.
234 my $num = scalar(@$inheritarr);
235 for ($i = 0; $i < $num; $i++) {
236 if (!$done{$inheritarr->[$i]}) {
237 $defer = 1;
238 push @next_vers, $name;
239 last;
242 next if ($defer);
244 # Add all the symbols from the inherited versions
245 # to this one.
246 for ($i = 0; $i < $num; $i++) {
247 my $i_version =
248 $obj->{'VERSION_INFO'}{$inheritarr->[$i]};
249 my $i_symhash = $i_version->[3];
251 foreach my $sym (keys %$i_symhash) {
252 if (!defined($cur_version->[3]{$sym})) {
253 $cur_version->[2]++;
254 $cur_version->[3]{$sym} = 'INHERIT';
259 $done{$name} = 1;
262 @vers = @next_vers;
263 @next_vers = ();
267 ## ReadInterface(file, alias)
269 # Read the interface description file, as produced by interface_check, and
270 # return a hash describing it.
272 # entry:
273 # file - Interface file to read.
274 # alias - Refence to hash to be filled in with any aliases
275 # that are seen in the file. The alias name is the key,
276 # and the object is the value.
278 # exit:
279 # The hash referenced by alias has been updated.
281 # The return value is a hash that encapsulates the interface
282 # information. This hash returned uses the object names as the
283 # key. Each key references a sub-hash that contains information
284 # for that object:
286 # CLASS -> ELFCLASS
287 # TYPE -> ELF type
288 # VERSION_NAMES -> Reference to array [1..n] of version names, in the
289 # order they come from the input file.
290 # VERSION_INFO -> Reference to hash indexed by version name, yielding
291 # a reference to an array containing information about
292 # that version.
294 # The arrays referenced via VERSION_INFO are of the form:
296 # (top, new, total, symhashref, inheritarrref)
298 # where:
299 # top - 1 if version is a TOP_VERSION, 0 for a regular VERSION
300 # new - Number of symbols defined explicitly by version
301 # total - Number of symbols included in version, both new,
302 # and via inheritance.
303 # symhashref - Reference to hash indexed by symbol names, and
304 # yielding true (1).
305 # inheritarrref - Reference to array of names of versions
306 # inherited by this one.
308 sub ReadInterface {
309 my ($file, $alias) = @_;
310 my %main_hash = ();
311 my $Line;
312 my $LineNum = 0;
313 my $obj_name;
314 my $obj_hash;
315 my $sym_ok = 0;
316 my $cur_version;
318 open(FILE, $file) || die "$Prog: Unable to open: $file";
320 # Until we see an OBJECT line, nothing else is valid. To
321 # simplify the error handling, use a simple initial loop to
322 # read the file up to that point
323 while ($Line = onbld_elfmod::GetLine(\*FILE, \$LineNum)) {
324 if ($Line =~ s/^OBJECT\s+//i) {
325 $obj_name = $Line;
326 $main_hash{$obj_name} = {};
327 $obj_hash = $main_hash{$obj_name};
328 last;
330 die "$file: OBJECT expected on line $LineNum: $Line\n";
333 # Read the remainder of the file
334 while ($Line = onbld_elfmod::GetLine(\*FILE, \$LineNum)) {
335 # Items are parsed in order of decreasing frequency
337 if ($Line =~
338 /^SYMBOL\s+([^\s]+)$/i) {
339 my $sym = $1;
341 die "$file: SYMBOL not expected on line $LineNum: $Line\n"
342 if !$sym_ok;
344 $cur_version->[1]++;
345 $cur_version->[2]++;
346 $cur_version->[3]{$sym} = 'NEW';
347 next;
350 if ($Line =~ /^((TOP_)?VERSION)\s+([^\s]+)(\s+\{(.*)\})?\s*$/i) {
351 my ($top, $name, $inherit) = ($2, $3, $5);
353 $top = defined($top) ? 1 : 0;
355 my @inheritarr = defined($inherit) ?
356 split /[,{\s]+/, $inherit : ();
358 $cur_version = [ $top, 0, 0, {}, \@inheritarr ];
359 $obj_hash->{'VERSION_INFO'}{$name} = $cur_version;
361 push @{$obj_hash->{'VERSION_NAMES'}}, $name;
362 $sym_ok = 1;
363 next;
366 if ($Line =~ /^OBJECT\s+([^\s]+)$/i) {
367 my $prev_obj_hash = $obj_hash;
368 $obj_name = $1;
369 $main_hash{$obj_name} = {};
370 $obj_hash = $main_hash{$obj_name};
372 # Expand the versions for the object just processed
373 ExpandInheritance($prev_obj_hash);
374 next;
377 if ($Line =~ /^CLASS\s+([^\s]+)$/i) {
378 $obj_hash->{'CLASS'} = $1;
379 next;
382 if ($Line =~ /^TYPE\s+([^\s]+)$/i) {
383 $obj_hash->{'TYPE'} = $1;
384 next;
387 if ($Line =~ /^ALIAS\s+([^\s]+)$/i) {
388 $$alias{$1} = $obj_name;
389 next;
392 die "$file: unrecognized item on line $LineNum: $Line\n";
394 close FILE;
396 # Expand the versions for the final object from the file
397 ExpandInheritance($obj_hash);
399 return %main_hash;
402 ## PrintInterface(main_hash, alias)
404 # Dump the contents of main_hash and alias to stdout in the same format
405 # used by interface_check to produce the input interface file. This output
406 # should diff cleanly against the original (ignoring the header comments).
408 sub PrintInterface {
409 my ($main_hash, $alias_hash) = @_;
411 foreach my $obj (sort keys %$main_hash) {
412 print "OBJECT\t$obj\n";
413 print "CLASS\t$main_hash->{$obj}{'CLASS'}\n";
414 print "TYPE\t$main_hash->{$obj}{'TYPE'}\n";
416 # This is inefficient, but good enough for debugging
417 # Look at all the aliases and print those that belong
418 # to this object.
419 foreach my $alias (sort keys %$alias_hash) {
420 print "ALIAS\t$alias\n"
421 if ($obj eq $alias_hash->{$alias});
424 next if !defined($main_hash->{$obj}{'VERSION_NAMES'});
426 my $num = scalar(@{$main_hash->{$obj}{'VERSION_NAMES'}});
427 my $i;
428 for ($i = 0; $i < $num; $i++) {
429 my $name = $main_hash->{$obj}{'VERSION_NAMES'}[$i];
430 my ($top, $direct, $total, $symhash, $inheritarr) =
431 @{$main_hash->{$obj}{'VERSION_INFO'}{$name}};
433 $top = $top ? "TOP_" : '';
435 my $inherit = (scalar(@$inheritarr) > 0) ?
436 "\t{" . join(', ', @{$inheritarr}) . "}" : '';
438 print "${top}VERSION\t$name$inherit\n";
440 foreach my $sym (sort keys %$symhash) {
441 print "\t$symhash->{$sym}\t$sym\n";
447 ## compare()
449 # Compare the old interface definition contained in (%old_hash, %old_alias)
450 # with the new interface contained in (%new_hash, %new_alias).
452 sub compare {
453 foreach my $old_obj (sort keys %old_hash) {
454 my $new_obj = $old_obj;
455 my $Ttl = 0;
457 # If the object does not exist in the new interface,
458 # then see if there's an alias for it. Failing that,
459 # we simply ignore the object.
460 if (!defined($new_hash{$new_obj})) {
461 next if !defined($new_alias{$new_obj});
462 $new_obj = $new_alias{$new_obj};
465 my $old = $old_hash{$old_obj};
466 my $new = $new_hash{$new_obj};
468 # Every version in the old object must exist in the new object,
469 # and there must be exactly the same symbols in each.
470 my $num = scalar(@{$old->{'VERSION_NAMES'}});
471 for (my $i = 0; $i < $num; $i++) {
472 my $name = $old->{'VERSION_NAMES'}[$i];
474 # New object must have this version
475 if (!defined($new->{'VERSION_INFO'}{$name})) {
476 onbld_elfmod::OutMsg2(\*STDOUT, \$Ttl, $old_obj,
477 $new_obj, "$name: deleted version");
478 next;
481 my ($old_top, $old_direct, $old_total, $old_symhash) =
482 @{$old->{'VERSION_INFO'}{$name}};
483 my ($new_top, $new_direct, $new_total, $new_symhash) =
484 @{$new->{'VERSION_INFO'}{$name}};
486 # If this is an empty top version, and the old object
487 # has the EMPTY_TOPVERSION exception set, then we
488 # skip it as if it were not present.
489 next if $old_top && ($old_direct == 0) &&
490 ExTopVer($name, $old_obj);
492 # We check that every symbol in the old object is
493 # in the new one to detect deleted symbols. We then
494 # check that every symbol in the new object is also
495 # in the old object, to find added symbols. If the
496 # "deleted" check is clean, and the two objects have
497 # the same number of symbols in their versions, then we
498 # can skip the "added" test, because we know that
499 # there is no room for an addition to have happened.
500 # Since most objects satisfy these constraints, we
501 # end up doing roughly half the number of comparisons
502 # that would otherwise be needed.
503 my $check_added_syms =
504 ($old_total == $new_total) ? 0: 1;
506 # Every symbol in the old version must be in the new one
507 foreach my $sym (sort keys %$old_symhash) {
508 if (!defined($new_symhash->{$sym})) {
509 onbld_elfmod::OutMsg2(\*STDOUT,
510 \$Ttl, $old_obj, $new_obj,
511 "$name: deleted interface: $sym")
512 if !ExSym(\@DelSymList,
513 $sym, $name, $new_obj);
514 $check_added_syms = 1;
518 # Do the "added" check, unless we can optimize it away.
519 # Every symbol in the new version must be in the old one.
520 if ($check_added_syms) {
521 foreach my $sym (sort keys %$new_symhash) {
522 if (!defined($old_symhash->{$sym})) {
523 next if ExSym(\@AddSymList,
524 $sym, $name, $new_obj);
525 onbld_elfmod::OutMsg2(\*STDOUT,
526 \$Ttl, $old_obj, $new_obj,
527 "$name: added interface: $sym");
532 # We want to ensure that version numbers in an
533 # inheritance chain don't go up by more than 1 in
534 # any given release. If the version names are in the
535 # numbered <PREFIX>x.y[.z] format, we can compare the
536 # two top versions and see if this has happened.
538 # For a given <PREFIX>x.y[.z], valid sucessors would
539 # be <PREFIX>x.(y+1) or <PREFIX>x.y.(z+1), where z is
540 # assumed to be 0 if not present.
542 # This check only makes sense when the new interface
543 # is a direct decendent of the old one, as specified
544 # via the -d option. If the two interfaces are more
545 # than one release apart, we should not do this test.
546 next if !($opt{d} && $old_top && !$new_top);
548 # Known numbered version?
550 # Key to @Cat contents:
551 # [0] 'NUMBERED'
552 # [1] number of dot separated numeric fields. 2 or 3.
553 # [2] prefix
554 # [3] major #
555 # [4] minor #
556 # [5] micro # (only if [1] is 3)
557 my @Cat = onbld_elfmod_vertype::Category($name, '');
558 next if ($Cat[0] ne 'NUMBERED');
560 my $iname1 = "$Cat[2]$Cat[3]." . ($Cat[4] + 1);
561 my $iname2;
562 if ($Cat[1] == 3) {
563 $iname2 = "$Cat[2]$Cat[3].$Cat[4]." . ($Cat[5] + 1);
564 } else {
565 $iname2 = "$Cat[2]$Cat[3].$Cat[4].1";
568 if (defined($new->{'VERSION_INFO'}{$iname1}) ||
569 defined($new->{'VERSION_INFO'}{$iname2})) {
570 my $i_top =
571 $new->{'VERSION_INFO'}{$iname1}[0] ||
572 $new->{'VERSION_INFO'}{$iname2}[0];
573 if (!$i_top) {
574 onbld_elfmod::OutMsg2(\*STDOUT,
575 \$Ttl, $old_obj, $new_obj,
576 "$name: inconsistant " .
577 "version increment: " .
578 "expect $iname1 or $iname2 ".
579 "to replace top version");
581 } else {
582 onbld_elfmod::OutMsg2(\*STDOUT,
583 \$Ttl, $old_obj, $new_obj,
584 "$name: expected superseding " .
585 "top version to $name not " .
586 "present: $iname1 or $iname2");
591 # Empty versions in the established interface description
592 # are usually the result of fixing a versioning mistake
593 # at some point in the past. These versions are part of
594 # the public record, and cannot be changed now. However, if
595 # comparing two interface descriptions from the same gate,
596 # flag any empty versions in the new interface description
597 # that are not present in the old one. These have yet to
598 # become part of the official interface, and should be removed
599 # before they do.
600 next if !$opt{d};
602 $num = scalar(@{$new->{'VERSION_NAMES'}});
603 for (my $i = 0; $i < $num; $i++) {
604 my $name = $new->{'VERSION_NAMES'}[$i];
606 # If old object has this version, skip it
607 next if defined($old->{'VERSION_INFO'}{$name});
609 # If explicitly whitelisted, skip it
610 next if ExTopVer($name, $new_obj);
612 my ($new_top, $new_direct, $new_total, $new_symhash) =
613 @{$new->{'VERSION_INFO'}{$name}};
615 if ($new_direct == 0) {
616 onbld_elfmod::OutMsg2(\*STDOUT,
617 \$Ttl, $old_obj, $new_obj,
618 "$name: invalid empty new version");
627 # -----------------------------------------------------------------------------
629 # Establish a program name for any error diagnostics.
630 chomp($Prog = `basename $0`);
632 # Check that we have arguments. Normally, 2 plain arguments are required,
633 # but if -t is present, only one is allowed.
634 if ((getopts('c:de:ot', \%opt) == 0) || (scalar(@ARGV) != ($opt{t} ? 1 : 2))) {
635 print "usage: $Prog [-dot] [-c vtype_mod] [-e exfile] old new\n";
636 print "\t[-c vtype_mod]\tsupply alternative version category module\n";
637 print "\t[-d]\t\tnew is a direct decendent of old\n";
638 print "\t[-e exfile]\texceptions file\n";
639 print "\t[-o]\t\tproduce one-liner output (prefixed with pathname)\n";
640 print "\t[-t]\tParse old, and recreate to stdout\n";
641 exit 1;
644 # We depend on the onbld_elfmod and onbld_elfmod_vertype perl modules.
645 # Both modules are maintained in the same directory as this script,
646 # and are installed in ../lib/perl. Use the local one if present,
647 # and the installed one otherwise.
649 # The caller is allowed to supply an alternative implementation for
650 # onbld_elfmod_vertype via the -c option. In this case, the alternative
651 # implementation is expected to provide the same interface as the standard
652 # copy, and is loaded instead.
654 my $moddir = my $vermoddir = dirname($0);
655 $moddir = "$moddir/../lib/perl" if ! -f "$moddir/onbld_elfmod.pm";
656 require "$moddir/onbld_elfmod.pm";
657 if ($opt{c}) {
658 require "$opt{c}";
659 } else {
660 $vermoddir = "$vermoddir/../lib/perl"
661 if ! -f "$vermoddir/onbld_elfmod_vertype.pm";
662 require "$vermoddir/onbld_elfmod_vertype.pm";
665 # Locate and process the exceptions file
666 LoadExceptions();
668 %old_alias = ();
669 %old_hash = ReadInterface($ARGV[0], \%old_alias);
671 # If -t is present, only one argument is allowed --- we parse it, and then
672 # print the same information back to stderr in the same format as the original.
673 # This is useful for debugging, to verify that the parsing is correct.
674 if ($opt{t}) {
675 PrintInterface(\%old_hash, \%old_alias);
676 exit 0;
679 %new_alias = ();
680 %new_hash = ReadInterface($ARGV[1], \%new_alias);
682 compare();
684 exit 0;