"Fossies" - the Fresh Open Source Software Archive

Member "mod_perl-2.0.11/util/apr_pool_check.pl" (5 Oct 2019, 1491 Bytes) of package /linux/www/apache_httpd_modules/mod_perl-2.0.11.tar.gz:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Perl source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file. For more information about "apr_pool_check.pl" see the Fossies "Dox" file reference documentation and the last Fossies "Diffs" side-by-side code changes report: 2.0.8_vs_2.0.9.

    1 #!/usr/bin/perl -w
    2 # please insert nothing before this line: -*- mode: cperl; cperl-indent-level: 4; cperl-continued-statement-offset: 4; indent-tabs-mode: nil -*-
    3 
    4 #check which apr_ functions do not have access to a pool
    5 
    6 use lib qw(lib);
    7 
    8 use strict;
    9 use Apache2::SourceTables ();
   10 
   11 my($functions, @nopool);
   12 
   13 #incomplete types (C::Scan only scans *.h, not *.c) we know have an apr_pool_t
   14 my %private = map { $_, 1 } qw{
   15 apr_dir_t apr_file_t apr_dso_handle_t apr_hash_t apr_hash_index_t apr_lock_t
   16 apr_socket_t apr_pollfd_t apr_threadattr_t apr_thread_t apr_threadkey_t
   17 apr_procattr_t apr_xlate_t apr_dbm_t apr_xml_parser
   18 };
   19 
   20 for my $entry (@$Apache2::FunctionTable) {
   21     next unless $entry->{name} =~ /^apr_/;
   22 
   23     $functions++;
   24 
   25     unless (grep { find_pool($_->{type}) } @{ $entry->{args} }) {
   26         push @nopool, $entry;
   27     }
   28 }
   29 
   30 my $num_nopool = @nopool;
   31 
   32 print "$num_nopool functions (out of $functions) do not have access to a pool:\n\n";
   33 
   34 for my $entry (@nopool) {
   35     print "$entry->{return_type} $entry->{name}(",
   36       (join ', ', map "$_->{type} $_->{name}", @{ $entry->{args} }),
   37         ")\n\n";
   38 }
   39 
   40 sub find_pool {
   41     my $type = shift;
   42 
   43     return 1 if $type =~ /^apr_pool_t/;
   44 
   45     $type =~ s/\s+\*+$//;
   46     $type =~ s/^(const|struct)\s+//g;
   47 
   48     if (my $elts = $Apache2::StructureTable{$type}) {
   49         return 1 if $private{$type};
   50 
   51         for my $e (@$elts) {
   52             next if $e->{type} =~ /^$type/;
   53             return 1 if find_pool($e->{type});
   54         }
   55     }
   56 }