icheck 0.9.7-6.2build1 / usr / share / icheck / perl5 / CParse / Namespace.pm

package CParse::Namespace;

use 5.6.0;
use strict;
use warnings;

use Carp;

sub new
  {
    my $this = shift;
    my $class = ref($this) || $this;
    my $self = {label => {},
                struct => {},
                union => {},
                enum => {},
                ordinary => {},
                baseline => undef,
                skip_from => {},
                skip_from_re => [],
                only_from => {},
                only_from_re => [],
               };
    bless $self, $class;
    return $self;
  }

sub baseline
  {
    my $self = shift;
    $self->{baseline} = shift;
  }

sub skip_from
  {
    my $self = shift;
    $self->{skip_from}{$_} = 1 foreach @_;
  }

sub skip_from_re
  {
    my $self = shift;
    push @{$self->{skip_from_re}}, @_;
  }

sub only_from
  {
    my $self = shift;
    $self->{only_from}{$_} = 1 foreach @_;
  }

sub only_from_re
  {
    my $self = shift;
    push @{$self->{only_from_re}}, @_;
  }

sub should_skip
  {
    my $self = shift;
    my $data = shift;
    my $kind = shift;
    my $name = shift;

    if ($self->{baseline})
      {
        return 1 if $self->{baseline}->get($kind, $name);
      }

    if ($data->file)
      {
        my $file = $data->file;

        # Skips first
        return 1 if $self->{skip_from}{$file};
        foreach (@{$self->{skip_from_re}})
          {
            return 1 if $file =~ $_;
          }

        # Stop if we don't have any onlys
        return 0 if not scalar keys %{$self->{only_from}} and not scalar @{$self->{only_from_re}};

        # Then the onlys
        return 0 if $self->{only_from}{$file};
        foreach (@{$self->{only_from_re}})
          {
            return 0 if $file =~ $_;
          }
        return 1;
      }
    else
      {
        return 0;
      }
  }

sub struct
  {
    my $self = shift;
    return $self->{struct};
  }

sub union
  {
    my $self = shift;
    return $self->{union};
  }

sub enum
  {
    my $self = shift;
    return $self->{enum};
  }

sub ordinary
  {
    my $self = shift;
    return $self->{ordinary};
  }

sub describe_thing
  {
    my $self = shift;
    my $kind = shift;
    my $name = shift;

    my $data = $self->get($kind, $name);
    unless ($data)
      {
        die "No such " . $self->describe_name($kind, $name);
      }

    if ($kind eq 'ordinary')
      {
        if ($data->isa('CDecl::Enumerator'))
          {
          }
        elsif ($data->isa('CDecl'))
          {
            print $data->describe($name) . "\n";
          }
        else
          {
            return if $data->isa('CType::Builtin') and $data->name eq $name;
            print "typedef $name: " . $data->describe . "\n";
          }
      }
    else
      {
        print "$kind $name: " . $data->describe . "\n";
      }
  }

sub describe
  {
    my $self = shift;

    return $self->describe_thing(@_) if scalar @_;

    foreach my $kind (qw/struct union enum ordinary/)
      {
        foreach my $name (sort keys %{$self->{$kind}})
          {
            my $data = $self->get($kind, $name);
            next if $self->should_skip($data, $kind, $name);
            $self->describe_thing($kind, $name);
          }
      }
  }

sub _dump_one_thing
  {
    my $self = shift;
    my $kind = shift;
    my $name = shift;
    my $skip_cpp = shift;

    my $data = $self->get($kind, $name);
    unless ($data)
      {
        die "No such " . $self->describe_name($kind, $name);
      }

    if ($kind eq 'ordinary')
      {
        if ($data->isa('CDecl::Enumerator'))
          {
            # We don't dump these directly, they're emitted as part of
            # the enum. We only find them here because enumerators get
            # pushed into the containing scope
            return;
          }
        elsif ($data->isa('CDecl'))
          {
            print $data->dump_c($skip_cpp);
          }
        else
          {
            return if $data->isa('CType::Builtin') and $data->name eq $name;
            if ($data->capture_declarator)
              {
                my $str = $data->dump_c(1, $name);
                $str =~ s/\n*$//;
                print $data->dump_location($skip_cpp);
                print "typedef $str;\n";
              }
            else
              {
                my $str = $data->dump_c(1);
                $str =~ s/\n*$//;
                print $data->dump_location($skip_cpp);
                print "typedef $str $name;\n";
              }
          }
      }
    else
      {
        my $str = $data->dump_c($skip_cpp, $name);
        $str =~ s/\n*$//;
        print $str . ";\n";
      }
  }

sub _dump_some_things
  {
    my $self = shift;
    my $things = shift;
    my $skip_cpp = shift;

    # First the declarations for the types that need them. This avoids
    # interdependencies
    foreach my $kind (qw/struct union enum/)
      {
        foreach my $name (sort keys %{$things->{$kind}})
          {
            print "$kind $name;\n";
          }
      }

    # Then the typedefs
    #
    # typedefs must be topologically sorted, because they have
    # interdependencies, and can't be pre-declared. This is the
    # depth-counting topological sort variant.

    my %depth;
    my @stack = map {{name => $_, depth => 1}} (keys %{$things->{ordinary}});
    while (scalar @stack)
      {
        my $x = pop @stack;

        if (not defined $depth{$x->{name}} or $depth{$x->{name}} < $x->{depth})
          {
            $depth{$x->{name}} = $x->{depth};
          }

        my $data = $self->get('ordinary', $x->{name});
        foreach my $ref ($data->get_refs)
          {
            # Only interested in typedefs. Everything else has already
            # been declared.
            next unless $ref->kind eq 'ordinary';

            # We don't worry about incomplete types here
            next unless $self->get($ref->kind, $ref->name);

            unshift @stack, {name => $ref->name, depth => $x->{depth} + 1};
          }
      }

    my @sequence = sort {$depth{$b} <=> $depth{$a} || $a cmp $b} keys %{$things->{ordinary}};

    foreach my $name (@sequence)
      {
        my $data = $self->get('ordinary', $name);
        next if $data->isa('CDecl');
        $self->_dump_one_thing('ordinary', $name, $skip_cpp);
      }

    # Then the structural types
    foreach my $kind (qw/struct union enum/)
      {
        foreach my $name (sort keys %{$things->{$kind}})
          {
            $self->_dump_one_thing($kind, $name, $skip_cpp);
          }
      }

    # Then the external declarations
    foreach my $name (sort keys %{$things->{ordinary}})
      {
        my $data = $self->get('ordinary', $name);
        next unless $data->isa('CDecl');
        $self->_dump_one_thing('ordinary', $name, $skip_cpp);
      }
  }

sub dump_thing
  {
    my $self = shift;
    my $kind = shift;
    my $name = shift;
    my $skip_cpp = shift;

    my $things = {};
    $things->{$kind}{$name} = 1;
    my $deps = $self->find_deps(undef, $things);
    $self->_dump_some_things($deps, $skip_cpp);
  }

sub dump
  {
    my $self = shift;
    my $skip_cpp = shift;

    my $things;
    foreach my $kind (qw/label struct union enum ordinary/)
      {
        foreach my $name (keys %{$self->{$kind}})
          {
            my $data = $self->get($kind, $name);
            next if $self->should_skip($data, $kind, $name);
            $things->{$kind}{$name} = 1;
          }
      }

    my $deps = $self->find_deps(undef, $things);
    $self->_dump_some_things($deps, $skip_cpp);
  }

sub compare_one_thing
  {
    my $self = shift;
    my $old = shift;
    my $kind = shift;
    my $name = shift;

    my $get_this = $self->get($kind, $name);
    my $get_old = $old->get($kind, $name);

    # We're not interested in comparing enumerators here; they are
    # handled in the comparison of the enum type itself. There are
    # five possible cases here:

    #  (enun and enum) - ignore
    #  (enum and missing) - ignore
    #  (missing and enum) - ignore
    #  (enum and X) - treat as (missing and X)
    #  (X and enum) - treat as (X and missing)

    # Factor these two values out to make this more readable
    my $this_enum = $get_this && $get_this->isa('CDecl::Enumerator');
    my $old_enum = $get_old && $get_old->isa('CDecl::Enumerator');
    if ($get_this and $get_old)
      {
        if ($this_enum and $old_enum)
          {
            return {};
          }
        elsif ($this_enum)
          {
            $get_this = undef;
          }
        elsif ($old_enum)
          {
            $get_old = undef;
          }
      }
    else
      {
        if ($this_enum)
          {
            return {};
          }
        elsif ($old_enum)
          {
            return {};
          }
      }

    if (not $get_this and not $get_old)
      {
        die "No such " . $self->describe_name($kind, $name);
      }
    elsif (not $get_this)
      {
        return if $self->should_skip($get_old, $kind, $name);

        my $ret;
        if ($kind eq 'ordinary' and $get_old->isa('CDecl'))
          {
            print "API and ABI removal: " . $self->describe_name($kind, $name) . " is gone\n";
            $ret = {api_forward => 1, abi_forward => 1};
          }
        else
          {
            print "API removal: " . $self->describe_name($kind, $name) . " is gone\n";
            $ret = {api_forward => 1};
          }
        my $location = $get_old->location;
        if ($location)
          {
            print " was defined at $location:\n";
          }
        else
          {
            print " was:\n";
          }
        $old->_dump_one_thing($kind, $name, 1);
        return $ret;
      }
    elsif (not $get_old)
      {
        return if $self->should_skip($get_this, $kind, $name);

        my $ret;
        if ($kind eq 'ordinary' and $get_this->isa('CDecl'))
          {
            print "API and ABI addition: " . $self->describe_name($kind, $name) . " is new\n";
            $ret = {api_backward => 1, abi_backward => 1};
          }
        else
          {
            print "API addition: " . $self->describe_name($kind, $name) . " is new\n";
            $ret = {api_backward => 1};
          }
        my $location = $get_this->location;
        if ($location)
          {
            print " is now defined at $location:\n";
          }
        else
          {
            print " is now:\n";
          }
        $self->_dump_one_thing($kind, $name, 1);
        return $ret;
      }
    else
      {
        if ($kind ne 'ordinary' or $get_this->isa('CDecl') and $get_old->isa('CDecl'))
          {
            my $ret;
            eval
              {
                $ret = $get_this->check_interface($get_old);
              };
            if ($@)
              {
                print STDERR "While trying to check " . $self->describe_name($kind, $name) . ":\n";
                die;
              }

            if ($kind ne 'ordinary' and grep {$ret->{$_}} keys %$ret)
              {
                my $location = $get_this->location;
                if ($location)
                  {
                    print " in type defined at $location:\n";
                  }
                else
                  {
                    print " in type:\n";
                  }
                $self->_dump_one_thing($kind, $name, 1);
                my $old_location = $get_old->location;
                if ($old_location)
                  {
                    print " versus type defined at $old_location:\n";
                  }
                else
                  {
                    print " versus type:\n";
                  }
                $old->_dump_one_thing($kind, $name, 1);
              }
            return $ret;
          }
        elsif ($get_this->isa('CDecl'))
          {
            print "API and ABI mismatch: declaration $name has become a typedef\n";
            return {api_forward => 1, api_backward => 1,
                    abi_forward => 1, abi_backward => 1};
          }
        elsif ($get_old->isa('CDecl'))
          {
            print "API and ABI mismatch: typedef $name has become a declaration\n";
            return {api_forward => 1, api_backward => 1,
                    abi_forward => 1, abi_backward => 1};
          }
        else
          {
            my @ret = $get_this->check_interface($get_old);
            my $ret = {};

            foreach (@ret)
              {
                foreach my $key (keys %$_)
                  {
                    $ret->{$key} = 1 if $_->{$key};
                  }
              }

            if (grep {$ret->{$_}} keys %$ret)
              {
                my $location = $get_this->location;
                if ($location)
                  {
                    print " in declaration at $location:\n";
                  }
                else
                  {
                    print " in declaration:\n";
                  }
                $self->_dump_one_thing($kind, $name, 1);
                my $old_location = $get_old->location;
                if ($old_location)
                  {
                    print " versus declaration at $old_location:\n";
                  }
                else
                  {
                    print " versus declaration:\n";
                  }
                $old->_dump_one_thing($kind, $name, 1);
              }

            return $ret;
          }
      }
  }

sub find_deps
  {
    my $self = shift;
    my $old = shift;
    my $things = shift;

    my %deps;
    my @queue;
    foreach my $kind (qw/struct union enum ordinary/)
      {
        foreach my $name (sort keys %{$things->{$kind}})
          {
            push @queue, {kind => $kind, name => $name};
          }
      }

    while (scalar @queue)
      {
        my $x = shift @queue;
        my $kind = $x->{kind};
        my $name = $x->{name};

        next if $deps{$kind}{$name};
        $deps{$kind}{$name} = 1;

        foreach my $data (grep {defined $_} ($self->get($kind, $name), $old ? $old->get($kind, $name) : undef))
          {
            foreach my $ref ($data->get_refs)
              {
                # We don't (can't) follow stuff that's not complete somewhere
                next unless $self->get($ref->kind, $ref->name) or ($old and $old->get($ref->kind, $ref->name));
                push @queue, {kind => $ref->kind, name => $ref->name};
              }
          }
      }

    # Anything that's in the baseline does not need to be emitted here
    if ($self->{baseline})
      {
        foreach my $kind (qw/struct union enum ordinary/)
          {
            foreach my $name (keys %{$deps{$kind}})
              {
                if ($self->{baseline}->get($kind, $name))
                  {
                    delete $deps{$kind}{$name};
                  }
              }
          }
      }

    return \%deps;
  }

sub compare_thing
  {
    my $self = shift;
    my $old = shift;
    my $kind = shift;
    my $name = shift;

    my $things = {};
    $things->{$kind}{$name} = 1;
    my $deps = $self->find_deps($old, $things);

    my $ret;

    foreach my $kind (qw/struct union enum ordinary/)
      {
        foreach my $name (sort keys %{$deps->{$kind}})
          {
            my $r = $self->compare_one_thing($old, $kind, $name);
            print "\n" if grep {$r->{$_}} keys %$r;
            foreach my $key (keys %$r)
              {
                $ret->{$key} = 1 if $r->{$key};
              }
          }
      }

    return $ret;
  }

sub describe_name
  {
    my $self = shift;
    my $kind = shift;
    my $name = shift;

    my $data = $self->get($kind, $name);
    if ($kind eq 'ordinary')
      {
        if (not $data or $data->isa('CDecl'))
          {
            return "identifier $name";
          }
        elsif ($data->isa('CDecl::Enumerator'))
          {
            return "enumerator $name";
          }
        else
          {
            return "typedef $name";
          }
      }
    else
      {
        return "$kind $name";
      }
  }

sub compare
  {
    my $self = shift;
    my $old = shift;

    my $ret;

    # We compare everything that's not in skip_from, plus everything
    # they depend on

    my $things;
    foreach my $kind (qw/struct union enum ordinary/)
      {
        foreach my $name (keys %{$self->{$kind}}, keys %{$old->{$kind}})
          {
            my $data = $self->get($kind, $name);
            next if $data and $self->should_skip($data, $kind, $name);

            my $old_data = $old->get($kind, $name);
            next if $old_data and $self->should_skip($old_data, $kind, $name);

            $things->{$kind}{$name} = 1;
          }
      }

    my $deps = $self->find_deps($old, $things);

    foreach my $kind (qw/struct union enum ordinary/)
      {
        foreach my $name (sort keys %{$deps->{$kind}})
          {
            my $r = $self->compare_one_thing($old, $kind, $name);
            print "\n" if grep {$r->{$_}} keys %$r;
            foreach my $key (keys %$r)
              {
                $ret->{$key} = 1 if $r->{$key};
              }
          }
      }

    return $ret;
  }

sub get_decls
  {
    my $self = shift;
    return grep {$_->isa('CDecl')} values %{$self->{ordinary}};
  }

sub get_types
  {
    my $self = shift;
    return (values %{$self->{struct}}, values %{$self->{union}}, values %{$self->{enum}}, grep {not $_->isa('CDecl')} values %{$self->{ordinary}});
  }

sub set
  {
    my $self = shift;
    my $kind = shift;
    my $name = shift;
    my $data = shift;

    $self->{$kind}{$name} = $data;
  }

sub get
  {
    my $self = shift;
    my $kind = shift;
    my $name = shift;

    return $self->{$kind}{$name};
  }

1;