icheck 0.9.7-6.2build1 / usr / bin / icheck

#!/usr/bin/perl

use 5.6.0;
use strict;
use warnings;

use FindBin;
use lib "/usr/share/icheck/perl5";
use lib "/usr/lib/icheck/perl5";
use lib $FindBin::Bin;
use lib $FindBin::Bin . "/ext/CParse-Parser-PerlXS/blib/lib";
use lib $FindBin::Bin . "/ext/CParse-Parser-PerlXS/blib/arch";

use IO::File;
use Getopt::Long qw/:config pass_through/;

use CParse;
use CParse::Namespace;
use CType::Builtin;
use CType::Native;
use CType::Ref;
use CExpr::Ref;

unless (defined $ENV{ICHECK_DEBUG} and $ENV{ICHECK_DEBUG} =~ /^\d+$/)
  {
    $ENV{ICHECK_DEBUG} = 0;
  }

sub usage
  {
    print <<END;
icheck --canonify [[--baseline FILE] ...] [OPTIONS] [GCC_OPTIONS] [--] files
icheck --compare [OPTIONS] old_file new_file

 --baseline FILE      Use FILE as a baseline reference, and do not emit
                      anything that is also present in it

Where OPTIONS can be:
 --debug [N]          Dump debugging information
 --only THING         Only process the given THING
  -o FILE
 --output FILE        Emit output to FILE, rather than stdout

These next four options filter based on name of the source file
being processed:

 --skip-from FILE     Skip unnecessary things from FILE
 --skip-from-re RE    Skip unnecessary things from files matching RE
 --only-from FILE     Only take things from FILE
 --only-from-re RE    Only take things from files matching RE

GCC_OPTIONS are passed through to gcc -E
END
    exit 0;
  }

my @baseline;
my $describe;
my $canonify;
my $compare;
my $only;
my $output;
my $verbose;
my @skip_from;
my @skip_from_re;
my @only_from;
my @only_from_re;
GetOptions('debug:+' => \$ENV{ICHECK_DEBUG},
           'baseline=s' => \@baseline,
           'describe' => \$describe,
           'canonify' => \$canonify,
           'compare' => \$compare,
           'only=s' => \$only,
           'output|o=s' => \$output,
           'verbose|v' => \$verbose,
           'skip-from=s' => \@skip_from,
           'skip-from-re=s' => \@skip_from_re,
           'only-from=s' => \@only_from,
           'only-from-re=s' => \@only_from_re,
           'help|h' => \&usage,
          );

usage if $compare and ($describe or $canonify or scalar @baseline);
usage unless $compare or $describe or $canonify;

my $output_file;
if ($output)
  {
    $output_file = new IO::File $output, "w";
    select $output_file;
  }

my @gcc_args;
my @sources;

while (scalar @ARGV)
  {
    my $arg = shift @ARGV;
    if ($arg eq '--')
      {
        push @sources, @ARGV;
        @ARGV = ();
        last;
      }

    if ($arg eq '-')
      {
        push @sources, '-';
        next;
      }

    if ($arg =~ /^-/)
      {
        push @gcc_args, $arg;
        next;
      }

    push @sources, $arg;
  }

my ($kind, $name);
if ($only)
  {
    if ($only =~ /^(struct|union|enum)\s+(.*)\s*$/)
      {
        $kind = $1;
        $name = $2;
      }
    else
      {
        $kind = 'ordinary';
        $name = $only;
        $name =~ s/^\s*//;
        $name =~ s/\s*$//;
      }
  }

sub do_compile
  {
    print STDERR "Compiling...\n" if $verbose;
    my $global = new CParse::Namespace;
    CType::Builtin::register_builtins($global);
    foreach my $file (@_)
      {
        print STDERR "Parsing $file...\n" if $verbose;
        my $unit = parse_file($file, @gcc_args);
        $_->process($global) foreach @$unit;
      }
    print STDERR "Completing references\n" if $verbose;
    CType::Ref::complete_refs($global);
    print STDERR "Laying out decls\n" if $verbose;
    $_->layout(0, $global) foreach $global->get_decls;
    print STDERR "Laying out types\n" if $verbose;
    $_->layout(1, $global) foreach $global->get_types;
    print STDERR "Done compiling\n" if $verbose;
    return $global;
  }

if ($compare)
  {
    usage unless scalar @sources == 2;

    my $old_file = $sources[0];
    my $new_file = $sources[1];

    my $old_global = do_compile($old_file);
    my $new_global = do_compile($new_file);

    $new_global->skip_from(@skip_from);
    $new_global->skip_from_re(@skip_from_re);
    $new_global->only_from(@only_from);
    $new_global->only_from_re(@only_from_re);

    my $result;

    print STDERR "Comparing...\n" if $verbose;
    if ($only)
      {
        $result = $new_global->compare_thing($old_global, $kind, $name);
      }
    else
      {
        $result = $new_global->compare($old_global);
      }

    if ($result->{abi_forward} and $result->{abi_backward})
      {
        print "ABI is not compatible\n";
      }
    elsif ($result->{abi_forward})
      {
        print "ABI is not forward-compatible\n";
      }
    elsif ($result->{abi_backward})
      {
        print "ABI is not backward-compatible\n";
      }

    if ($result->{api_forward} and $result->{api_backward})
      {
        print "API is not compatible\n";
      }
    elsif ($result->{api_forward})
      {
        print "API is not forward-compatible\n";
      }
    elsif ($result->{api_backward})
      {
        print "API is not backward-compatible\n";
      }

    if (grep {$result->{$_}} keys %$result)
      {
        exit 1;
      }
    else
      {
        exit 0;
      }
  }

my $global = do_compile(@sources);
$global->skip_from(@skip_from);
$global->skip_from_re(@skip_from_re);
$global->only_from(@only_from);
$global->only_from_re(@only_from_re);

if (scalar @baseline)
  {
    my $baseline = do_compile(@baseline);
    $global->baseline($baseline);
  }

if ($describe)
  {
    print STDERR "Describing...\n" if $verbose;
    if ($only)
      {
        $global->describe_thing($kind, $name);
      }
    else
      {
        $global->describe;
      }
  }

if ($canonify)
  {
    print STDERR "Canonifying...\n" if $verbose;
    if ($only)
      {
        $global->dump_thing($kind, $name);
      }
    else
      {
        $global->dump;
      }
  }

exit 0;