cvs commit: modperl-2.0/lib/ModPerl FunctionMap.pm

[dougm]

dougm       01/03/04 19:44:58

  Added:       lib/ModPerl FunctionMap.pm
  Log:
  module for mapping functions
  
  Revision  Changes    Path
  1.1                  modperl-2.0/lib/ModPerl/FunctionMap.pm
  
  Index: FunctionMap.pm
  ===================================================================
  package ModPerl::FunctionMap;
  
  use strict;
  use warnings FATAL => 'all';
  use ModPerl::MapUtil qw();
  use ModPerl::ParseSource ();
  use Apache::FunctionTable ();
  use ModPerl::FunctionTable ();
  
  our @ISA = qw(ModPerl::MapBase);
  
  sub new {
      my $class = shift;
      bless {}, $class;
  }
  
  #for adding to function.map
  sub generate {
      my $self = shift;
  
      my $missing = $self->check;
      return unless $missing;
  
      print " $_\n" for @$missing;
  }
  
  sub disabled { shift->{disabled} }
  
  #look for functions that do not exist in *.map
  sub check {
      my $self = shift;
      my $map = $self->get;
  
      my @missing;
      my $mp_func = ModPerl::ParseSource->wanted_functions;
  
      for my $name (map $_->{name}, @{ $self->function_table() }) {
          next if exists $map->{$name};
          push @missing, $name unless $name =~ /^($mp_func)/o;
      }
  
      return @missing ? \@missing : undef;
  }
  
  #look for functions in *.map that do not exist
  my $special_name = qr{(^DEFINE_|DESTROY$)};
  
  sub check_exists {
      my $self = shift;
  
      my %functions = map { $_->{name}, 1 } @{ $self->function_table() };
      my @missing = ();
  
      for my $name (keys %{ $self->{map} }) {
          next if $functions{$name};
          push @missing, $name unless $name =~ $special_name;
      }
  
      return @missing ? \@missing : undef;
  }
  
  my $keywords = join '|', qw(MODULE PACKAGE PREFIX);
  
  sub guess_prefix {
      my $entry = shift;
  
      my($name, $class) = ($entry->{name}, $entry->{class});
      my $prefix = "";
      $name =~ s/^DEFINE_//;
  
      (my $guess = lc($entry->{class} || $entry->{module}) . '_') =~ s/::/_/g;
      $guess =~ s/apache_/ap_/;
  
      if ($name =~ /^$guess/) {
          $prefix = $guess;
      }
      else {
          if ($name =~ /^(apr?_)/) {
              $prefix = $1;
          }
      }
  
      #print "GUESS prefix=$guess, name=$entry->{name} -> $prefix\n";
  
      return $prefix;
  }
  
  sub parse {
      my($self, $fh, $map) = @_;
      my %cur;
      my $disabled = 0;
  
      while ($fh->readline) {
          if (/($keywords)=/o) {
              $disabled = s/^\W//; #module is disabled
              my %words = $self->parse_keywords($_);
  
              if ($words{MODULE}) {
                  %cur = ();
              }
  
              for (keys %words) {
                  $cur{$_} = $words{$_};
              }
  
              next;
          }
  
          my($name, $dispatch, $argspec, $alias) = split /\s*\|\s*/;
          my $return_type;
  
          if ($name =~ s/^([^:]+)://) {
              $return_type = $1;
          }
  
          if ($name =~ s/^(\W)// or not $cur{MODULE} or $disabled) {
              #notimplemented or cooked by hand
              $map->{$name} = undef;
              push @{ $self->{disabled}->{ $1 || '!' } }, $name;
              next;
          }
  
          my $entry = $map->{$name} = {
             name        => $alias || $name,
             dispatch    => $dispatch,
             argspec     => $argspec ? [split /\s*,\s*/, $argspec] : "",
             return_type => $return_type,
             alias       => $alias,
          };
  
          if (my $package = $cur{PACKAGE}) {
              unless ($package eq 'guess') {
                  $cur{CLASS} = $package;
              }
          }
          else {
              $cur{CLASS} = $cur{MODULE};
          }
  
          for (keys %cur) {
              $entry->{lc $_} = $cur{$_};
          }
  
          $entry->{prefix} ||= guess_prefix($entry);
  
          #avoid 'use of uninitialized value' warnings
          $entry->{$_} ||= "" for keys %{ $entry };
          if ($entry->{dispatch} =~ /_$/) {
              $entry->{dispatch} .= $name;
          }
      }
  }
  
  sub get {
      my $self = shift;
  
      $self->{map} ||= $self->parse_map_files;
  }
  
  sub prefixes {
      my $self = shift;
      $self = ModPerl::FunctionMap->new unless ref $self;
  
      my $map = $self->get;
      my %prefix;
  
      while (my($name, $ent) = each %$map) {
          next unless $ent->{prefix};
          $prefix{ $ent->{prefix} }++;
      }
  
      [keys %prefix]
  }
  
  1;
  __END__