cvs commit: modperl-2.0/util apr_pool_check.pl

[dougm]

dougm       01/03/15 18:32:44

  Added:       util     apr_pool_check.pl
  Log:
  script to check which apr_ functions do not have access to a pool
  
  Revision  Changes    Path
  1.1                  modperl-2.0/util/apr_pool_check.pl
  
  Index: apr_pool_check.pl
  ===================================================================
  #check which apr_ functions do not have access to a pool
  
  use lib qw(lib);
  
  use strict;
  use Apache::SourceTables ();
  
  my($functions, @nopool);
  
  #incomplete types (C::Scan only scans *.h, not *.c) we know have an apr_pool_t
  my %private = map { $_, 1 } qw{
  apr_dir_t apr_file_t apr_dso_handle_t apr_hash_t apr_hash_index_t apr_lock_t
  apr_socket_t apr_pollfd_t apr_threadattr_t apr_thread_t apr_threadkey_t
  apr_procattr_t apr_xlate_t apr_dbm_t apr_xml_parser
  };
  
  for my $entry (@$Apache::FunctionTable) {
      next unless $entry->{name} =~ /^apr_/;
  
      $functions++;
  
      unless (grep { find_pool($_->{type}) } @{ $entry->{args} }) {
          push @nopool, $entry;
      }
  }
  
  my $num_nopool = @nopool;
  
  print "$num_nopool functions (out of $functions) do not have access to a pool:\n\n";
  
  for my $entry (@nopool) {
      print "$entry->{return_type} $entry->{name}(",
        (join ', ', map "$_->{type} $_->{name}", @{ $entry->{args} }),
          ")\n\n";
  }
  
  sub find_pool {
      my $type = shift;
  
      return 1 if $type =~ /^apr_pool_t/;
  
      $type =~ s/\s+\*+$//;
      $type =~ s/^(const|struct)\s+//g;
  
      if (my $elts = $Apache::StructureTable{$type}) {
          return 1 if $private{$type};
  
          for my $e (@$elts) {
              next if $e->{type} =~ /^$type/;
              return 1 if find_pool($e->{type});
          }
      }
  }