perl-modperl-cvs mailing list archives

Site index · List index
Message view « Date » · « Thread »
Top « Date » · « Thread »
From s...@apache.org
Subject cvs commit: modperl-2.0 Changes
Date Thu, 17 Apr 2003 01:19:55 GMT
stas        2003/04/16 18:19:55

  Modified:    lib/ModPerl WrapXS.pm
               .        Changes
  Log:
  improving ModPerl::MethodLookup to:
  - handle more aliased perl XS functions
  - sort the methods map struct so one can use the autogenerated map as is
  - add lookup_module, tells which methods are defined by a given module
  - add lookup_object, tells which methods can be called on a given  object
  - provide autoexported wrappers print_method, print_module and
    print_object for easy deployment from the command line
  
  Revision  Changes    Path
  1.57      +153 -15   modperl-2.0/lib/ModPerl/WrapXS.pm
  
  Index: WrapXS.pm
  ===================================================================
  RCS file: /home/cvs/modperl-2.0/lib/ModPerl/WrapXS.pm,v
  retrieving revision 1.56
  retrieving revision 1.57
  diff -u -r1.56 -r1.57
  --- WrapXS.pm	31 Mar 2003 00:33:57 -0000	1.56
  +++ WrapXS.pm	17 Apr 2003 01:19:55 -0000	1.57
  @@ -585,7 +585,8 @@
               my $prefix = $func->{prefix};
               $last_prefix = $prefix if $prefix;
   
  -            my $name = $func->{name};
  +            my $name = $func->{perl_name} || $func->{name};
  +            $name =~ s/^DEFINE_//;
   
               if ($name =~ /^mpxs_/) {
                   #e.g. mpxs_Apache__RequestRec_
  @@ -604,8 +605,10 @@
           }
       }
   
  -    local $Data::Dumper::Terse = 1;
  -    $Data::Dumper::Terse = $Data::Dumper::Terse; # warn
  +    local $Data::Dumper::Terse    = 1;
  +    local $Data::Dumper::Sortkeys = 1;
  +    $Data::Dumper::Terse    = $Data::Dumper::Terse;    # warn
  +    $Data::Dumper::Sortkeys = $Data::Dumper::Sortkeys; # warn
       my $methods = Dumper(\%map);
       $methods =~ s/\n$//;
   
  @@ -628,18 +631,71 @@
   EOF
   
       print $fh <<'EOF';
  +
  +use base qw(Exporter);
  +
  +our @EXPORT = qw(print_method print_module print_object);
  +
   use constant MODULE => 0;
  -use constant CLASS  => 1;
  +use constant OBJECT  => 1;
  +
  +my $modules;
  +my $objects;
  +
  +sub _get_modules {
  +    for my $method (sort keys %$methods) { 
  +        for my $item ( @{ $methods->{$method} }) {
  +            push @{ $modules->{$item->[MODULE]} }, [$method, $item->[OBJECT]];
  +        }
  +    }
  +}
  +
  +sub _get_objects {
  +    for my $method (sort keys %$methods) { 
  +        for my $item ( @{ $methods->{$method} }) {
  +            push @{ $objects->{$item->[OBJECT]} }, [$method, $item->[MODULE]];
  +        }
  +    }
  +}
   
   sub preload_all_modules {
  -    eval "require $_" for map $_->[MODULE], map @$_, values %$methods;
  +    _get_modules() unless $modules;
  +    eval "require $_" for keys %$modules;
   }
   
  +sub _print_func {
  +    my $func = shift;
  +    my @args = @_ ? @_ : @ARGV;
  +    no strict 'refs';
  +    print( ($func->($_))[0]) for @args;
  +}
  +
  +sub print_module { _print_func('lookup_module', @_) }
  +sub print_object { _print_func('lookup_object', @_) }
  +
  +sub print_method {
  +    my @args = @_ ? @_ : @ARGV;
  +    while (@args) {
  +         my $method = shift @args;
  +         my $object = (@args && 
  +             (ref($args[0]) || $args[0] =~ /^(Apache|ModPerl|APR)/))
  +             ? shift @args
  +             : undef;
  +         print( (lookup_method($method, $object))[0]);
  +    }
  +}
  +
  +sub sep { return '-' x (shift() + 20) . "\n" }
  +
  +# what modules contain the passed method.
  +# an optional object or a reference to it can be passed to help
  +# resolve situations where there is more than one module containing
  +# the same method.
   sub lookup_method {
  -    my ($method, $arg) = @_;
  +    my ($method, $object) = @_;
   
       unless (defined $method) {
  -        my $hint = "no 'method' argument was passed";
  +        my $hint = "No 'method' argument was passed\n";
           return ($hint);
       }
   
  @@ -647,7 +703,7 @@
       $method =~ s/.+:://;
   
       unless (exists $methods->{$method}) {
  -        my $hint = "don't know anything about method '$method'";
  +        my $hint = "Don't know anything about method '$method'\n";
           return ($hint);
       }
   
  @@ -658,10 +714,10 @@
           return ($hint, $module);
       }
       else {
  -        if (defined $arg and ref $arg) {
  -            my $class = ref $arg;
  +        if (defined $object) {
  +            my $class = ref $object || $object;
               for my $item (@items) {
  -                if ($class eq $item->[CLASS]) {
  +                if ($class eq $item->[OBJECT]) {
                       my $module = $item->[MODULE];
                       my $hint = "to use method '$method' add:\n" .
                           "\tuse $module ();\n";
  @@ -670,12 +726,94 @@
               }
           }
           else {
  -            my @modules = map {$_->[MODULE]} @items;
  -            my $hint = "There is more than one class with method '$method'\n" .
  -                "try one of:\n" . join '', map {"\tuse $_ ();\n"} @modules;
  -            return ($hint, @modules);
  +            my %modules = map { $_->[MODULE] => 1 } @items;
  +            # remove dups if any (e.g. $s->add_input_filter and
  +            # $r->add_input_filter are loaded by the same Apache::Filter)
  +            my @modules = keys %modules;
  +            my $hint;
  +            if (@modules == 1) {
  +                $hint = "To use method '$method' add:\n\tuse $modules[0] ();\n";
  +                return ($hint, $modules[0]);
  +            }
  +            else {
  +                $hint = "There is more than one class with method '$method'\n" .
  +                    "try one of:\n" . join '', map {"\tuse $_ ();\n"} @modules;
  +                return ($hint, @modules);
  +            }
           }
       }
  +}
  +
  +# what methods are contained in the passed module name
  +sub lookup_module {
  +    my ($module) = shift;
  +
  +    unless (defined $module) {
  +        my $hint = "no 'module' argument was passed\n";
  +        return ($hint);
  +    }
  +
  +    _get_modules() unless $modules;
  +
  +    unless (exists $modules->{$module}) {
  +        my $hint = "don't know anything about module '$module'\n";
  +        return ($hint);
  +    }
  +
  +    my @methods;
  +    my $max_len = 6;
  +    for ( @{ $modules->{$module} } ) {
  +        $max_len = length $_->[0] if length $_->[0] > $max_len;
  +        push @methods, $_->[0];
  +    }
  +
  +    my $format = "%-${max_len}s %s\n";
  +    my $banner = sprintf($format, "Method", "Invoked on object type");
  +    my $hint = join '',
  +        ("\nModule '$module' contains the following XS methods:\n\n", 
  +         $banner,  sep(length($banner)),
  +         map( { sprintf $format, $_->[0], $_->[1]} @{ $modules->{$module} }),
  +         sep(length($banner)));
  +
  +    return ($hint, @methods);
  +}
  +
  +# what methods can be invoked on the passed object (or its reference)
  +sub lookup_object {
  +    my ($object) = shift;
  +
  +    unless (defined $object) {
  +        my $hint = "no 'object' argument was passed\n";
  +        return ($hint);
  +    }
  +
  +    _get_objects() unless $objects;
  +
  +    # a real object was passed?
  +    $object = ref $object || $object;
  +
  +    unless (exists $objects->{$object}) {
  +        my $hint = "don't know anything about objects of type '$object'\n";
  +        return ($hint);
  +    }
  +
  +    my @methods;
  +    my $max_len = 6;
  +    for ( @{ $objects->{$object} } ) {
  +        $max_len = length $_->[0] if length $_->[0] > $max_len;
  +        push @methods, $_->[0];
  +    }
  +
  +    my $format = "%-${max_len}s %s\n";
  +    my $banner = sprintf($format, "Method", "Module");
  +    my $hint = join '',
  +        ("\nObjects of type '$object' can invoke the following XS methods:\n\n",
  +         $banner, sep(length($banner)),
  +         map({ sprintf $format, $_->[0], $_->[1]} @{ $objects->{$object} }),
  +         sep(length($banner)));
  +
  +    return ($hint, @methods);
  +
   }
   
   1;
  
  
  
  1.173     +9 -0      modperl-2.0/Changes
  
  Index: Changes
  ===================================================================
  RCS file: /home/cvs/modperl-2.0/Changes,v
  retrieving revision 1.172
  retrieving revision 1.173
  diff -u -r1.172 -r1.173
  --- Changes	15 Apr 2003 08:39:52 -0000	1.172
  +++ Changes	17 Apr 2003 01:19:55 -0000	1.173
  @@ -10,6 +10,15 @@
   
   =item 1.99_09-dev
   
  +improving ModPerl::MethodLookup to:
  +- handle more aliased perl XS functions
  +- sort the methods map struct so one can use the autogenerated map as is
  +- add lookup_module, tells which methods are defined by a given module
  +- add lookup_object, tells which methods can be called on a given object
  +- provide autoexported wrappers print_method, print_module and
  +  print_object for easy deployment from the command line
  +[Stas]
  +
   add Perl glue for functions: APR::Socket::timeout_get
   APR::Socket::timeout_set [Stas]
   
  
  
  

Mime
View raw message