xref: /dports/www/mod_perl2/mod_perl-2.0.11/lib/ModPerl/WrapXS.pm

# please insert nothing before this line: -*- mode: cperl; cperl-indent-level: 4; cperl-continued-statement-offset: 4; indent-tabs-mode: nil -*-
# Licensed to the Apache Software Foundation (ASF) under one or more
# contributor license agreements.  See the NOTICE file distributed with
# this work for additional information regarding copyright ownership.
# The ASF licenses this file to You under the Apache License, Version 2.0
# (the "License"); you may not use this file except in compliance with
# the License.  You may obtain a copy of the License at
#
#     http://www.apache.org/licenses/LICENSE-2.0
#
# Unless required by applicable law or agreed to in writing, software
# distributed under the License is distributed on an "AS IS" BASIS,
# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
# See the License for the specific language governing permissions and
# limitations under the License.
#
package ModPerl::WrapXS;

use strict;
use warnings FATAL => 'all';

use constant GvUNIQUE => 0; #$] >= 5.008;
use Apache::TestTrace;
use Apache2::Build ();
use ModPerl::Code ();
use ModPerl::TypeMap ();
use ModPerl::MapUtil qw(function_table xs_glue_dirs);
use File::Path qw(rmtree mkpath);
use Cwd qw(fastcwd);
use Data::Dumper;
use File::Spec::Functions qw(catfile catdir);

our $VERSION = '0.01';

my (@xs_includes) = ('mod_perl.h',
                    map "modperl_xs_$_.h", qw(sv_convert util typedefs));

my @global_structs = qw(perl_module);

my $build = Apache2::Build->build_config;
push @global_structs, 'MP_debug_level' unless Apache2::Build::WIN32;

sub new {
    my $class = shift;

    my $self = bless {
       typemap   => ModPerl::TypeMap->new,
       includes  => \@xs_includes,
       glue_dirs => [xs_glue_dirs()],
    }, $class;

    $self->typemap->get;
    $self;
}

sub typemap  { shift->{typemap} }

sub includes { shift->{includes} }

sub function_list {
    my $self = shift;
    my (@list) = @{ function_table() };

    while (my ($name, $val) = each %{ $self->typemap->function_map }) {
        #entries that do not exist in C::Scan generated tables
        next unless $name =~ /^DEFINE_/;
        push @list, $val;
    }

    return \@list;
}

sub get_functions {
    my $self = shift;
    my $typemap = $self->typemap;

    for my $entry (sort { $a->{name} cmp $b->{name} } @{ $self->function_list() }) {
        my $func = $typemap->map_function($entry);
        #print "FAILED to map $entry->{name}\n" unless $func;
        next unless $func;

        my ($name, $module, $class, $args) =
          @{ $func } { qw(perl_name module class args) };

        $self->{XS}->{ $module } ||= [];

        #eg ap_fputs()
        if ($name =~ s/^DEFINE_//) {
            $func->{name} =~ s/^DEFINE_//;

            if (needs_prefix($func->{name})) {
                #e.g. DEFINE_add_output_filter
                $func->{name} = make_prefix($func->{name}, $class);
            }
        }

        my $xs_parms = join ', ',
          map { defined $_->{default} ?
                  "$_->{name}=$_->{default}" : $_->{name} } @$args;

        (my $parms = $xs_parms) =~ s/=[^,]+//g; #strip defaults

        my $proto = join "\n",
          (map "    $_->{type} $_->{name}", @$args), "";

        my ($dispatch, $orig_args) =
          @{ $func } {qw(dispatch orig_args)};

        if ($dispatch =~ /^MPXS_/) {
            $name =~ s/^mpxs_//;
            $name =~ s/^$func->{prefix}//;
            push @{ $self->{newXS}->{ $module } },
              ["$class\::$name", $dispatch];
            next;
        }

        my $passthru = @$args && $args->[0]->{name} eq '...';
        if ($passthru) {
            $parms = '...';
            $proto = '';
        }

        my $return_type =
          $name =~ /^DESTROY$/ ? 'void' : $func->{return_type};

        my $attrs = $self->attrs($name);

        my $code = <<EOF;
$return_type
$name($xs_parms)
$proto
$attrs
EOF

        if ($dispatch || $orig_args || $func->{thx}) {
            my $thx = $func->{thx} ? 'aTHX_ ' : "";

            if ($dispatch) {
                $thx = 'aTHX_ ' if $dispatch =~ /^mpxs_/i;
            }
            else {
                if ($orig_args and @$orig_args == @$args) {
                    #args were reordered
                    $parms = join ', ', @$orig_args;
                }

                $dispatch = $func->{name};
            }

            if ($passthru) {
                $thx ||= 'aTHX_ ';
                $parms = 'items, MARK+1, SP';
            }

            $thx =~ s/_ $// unless $parms;

            my $retval = $return_type eq 'void' ?
              ["", ""] : ["RETVAL = ", "OUTPUT:\n    RETVAL\n"];

            my $avoid_warning = "";
            if (@$args and not $passthru) {
                $avoid_warning = "    /* avoiding -Wall warnings */\n";
                $avoid_warning .= join "\n",
                    (map "    $_->{name} = $_->{name};", @$args), "";
            }
            $code .= <<EOF;
    CODE:
$avoid_warning
    $retval->[0]$dispatch($thx$parms);

    $retval->[1]
EOF
        }

        $func->{code} = $code;
        push @{ $self->{XS}->{ $module } }, $func;
    }
}

sub get_value {
    my $e = shift;
    my $val = 'val';

    if ($e->{class} eq 'PV') {
        if (my $pool = $e->{pool}) {
            $pool .= '(obj)';
            $val = "(SvOK(ST(1)) ?
                    apr_pstrndup($pool, val, val_len) : NULL)"
        }
    }

    return $val;
}

sub get_structures {
    my $self = shift;
    my $typemap = $self->typemap;

    require Apache2::StructureTable;
    for my $entry (@$Apache2::StructureTable) {
        my $struct = $typemap->map_structure($entry);
        next unless $struct;

        my $class = $struct->{class};

        for my $e (@{ $struct->{elts} }) {
            my ($name, $default, $type, $access_mode) =
              @{$e}{qw(name default type access_mode)};

            (my $cast = $type) =~ s/:/_/g;
            my $val = get_value($e);

            my $type_in = $type;
            my $preinit = "/*nada*/";
            if ($e->{class} eq 'PV' and $val ne 'val') {
                $type_in =~ s/char/char_len/;
                $preinit = "STRLEN val_len;";
            }

            my $attrs = $self->attrs($name);

            my $code;
            if ($access_mode eq 'ro') {
                $code = <<EOF;
$type
$name(obj)
    $class obj

$attrs

    CODE:
    RETVAL = ($cast) obj->$name;

    OUTPUT:
    RETVAL

EOF
            }
            elsif ($access_mode eq 'rw' or $access_mode eq 'r+w_startup') {

                my $check_runtime = $access_mode eq 'rw'
                    ? ''
                    : qq[MP_CROAK_IF_THREADS_STARTED("setting $name");];

                $code = <<EOF;
$type
$name(obj, val=$default)
    $class obj
    $type_in val

    PREINIT:
    $preinit
$attrs

    CODE:
    RETVAL = ($cast) obj->$name;

    if (items > 1) {
         $check_runtime
         obj->$name = ($cast) $val;
    }

    OUTPUT:
    RETVAL

EOF
            }
            elsif ($access_mode eq 'r+w_startup_dup') {

                my $convert = $cast !~ /\bchar\b/
                    ? "mp_xs_sv2_$cast"
                    : "SvPV_nolen";

                $code = <<EOF;
$type
$name(obj, val=(SV *)NULL)
    $class obj
    SV *val

    PREINIT:
    $preinit
$attrs

    CODE:
    RETVAL = ($cast) obj->$name;

    if (items > 1) {
         SV *dup = get_sv("_modperl_private::server_rec_$name", TRUE);
         MP_CROAK_IF_THREADS_STARTED("setting $name");
         sv_setsv(dup, val);
         obj->$name = ($cast)$convert(dup);
    }

    OUTPUT:
    RETVAL

EOF
            }
            elsif ($access_mode eq 'rw_char_undef') {
                my $pool = $e->{pool}
                    or die "rw_char_undef accessors need pool";
                $pool .= '(obj)';
# XXX: not sure where val=$default is coming from, but for now use
# hardcoded (SV *)NULL
                $code = <<EOF;
$type
$name(obj, val_sv=(SV *)NULL)
    $class obj
    SV *val_sv

    PREINIT:
$attrs

    CODE:
    RETVAL = ($cast) obj->$name;

    if (val_sv) {
        if (SvOK(val_sv)) {
            STRLEN val_len;
            char *val = (char *)SvPV(val_sv, val_len);
            obj->$name = apr_pstrndup($pool, val, val_len);
        }
        else {
            obj->$name = NULL;
        }
    }

    OUTPUT:
    RETVAL

EOF
            }

            push @{ $self->{XS}->{ $struct->{module} } }, {
               code  => $code,
               class => $class,
               name  => $name,
            };
        }
    }
}

sub prepare {
    my $self = shift;
    $self->{DIR} = 'WrapXS';
    $self->{XS_DIR} = catdir fastcwd(), 'xs';

    my $verbose = Apache::TestTrace::trace_level() eq 'debug' ? 1 : 0;

    if (-e $self->{DIR}) {
        rmtree([$self->{DIR}], $verbose, 1);
    }

    mkpath [$self->{DIR}], $verbose, 0755;
}

sub class_dirname {
    my ($self, $class) = @_;
    my ($base, $sub) = split '::', $class;
    return "$self->{DIR}/$base" unless $sub; #Apache2 | APR
    return $sub if $sub eq $self->{DIR}; #WrapXS
    return "$base/$sub";
}

sub class_dir {
    my ($self, $class) = @_;

    my $dirname = $self->class_dirname($class);
    my $dir = ($dirname =~ m:/: and $dirname !~ m:^$self->{DIR}:) ?
      catdir($self->{DIR}, $dirname) : $dirname;

    unless (-d $dir) {
        mkpath [$dir], 0, 0755;
        debug "mkdir.....$dir";
    }

    $dir;
}

sub class_file {
    my ($self, $class, $file) = @_;
    catfile $self->class_dir($class), $file;
}

sub cname {
    my ($self, $class) = @_;
    $class =~ s/:/_/g;
    $class;
}

sub open_class_file {
    my ($self, $class, $file) = @_;

    if ($file =~ /^\./) {
        my $sub = (split '::', $class)[-1];
        $file = $sub . $file;
    }

    my $name = $self->class_file($class, $file);

    open my $fh, '>', $name or die "open $name: $!";
    debug "writing...$name";

    return $fh;
}

sub module_version {
    local $_ = shift;
    require mod_perl2;
    # XXX: for now APR gets its libapr-0.9 version
    return /^APR/ ? "0.009000" : "$mod_perl2::VERSION";
}

sub write_makefilepl {
    my ($self, $class) = @_;

    my $fh = $self->open_class_file($class, 'Makefile.PL');

    my $includes = $self->includes;
    my $xs = (split '::', $class)[-1] . '.c';
    my $deps = {$xs => ""};

    if (my $mod_h = $self->mod_h($class, 1)) {
        $deps->{$xs} .= " $mod_h";
    }

    local $Data::Dumper::Terse = 1;
    $deps = Dumper $deps;

    my $noedit_warning = $self->ModPerl::Code::noedit_warning_hash();
    require mod_perl2;
    my $version = module_version($class);

    print $fh <<EOF;
$noedit_warning

use lib qw(../../../lib); #for Apache2::BuildConfig
use ModPerl::BuildMM ();

ModPerl::BuildMM::WriteMakefile(
    'NAME'    => '$class',
    'VERSION' => '$version',
    'depend'  => $deps,
);
EOF

    close $fh;
}

sub mod_h {
    my ($self, $module, $complete) = @_;

    my $dirname = $self->class_dirname($module);
    my $cname = $self->cname($module);
    my $mod_h = "$dirname/$cname.h";

    for ($self->{XS_DIR}, @{ $self->{glue_dirs} }) {
        my $file = "$_/$mod_h";
        $mod_h = $file if $complete;
        return $mod_h if -e $file;
    }

    undef;
}

sub mod_pm {
    my ($self, $module, $complete) = @_;

    my $dirname = $self->class_dirname($module);
    my ($base, $sub) = split '::', $module;
    my $mod_pm = "$dirname/${sub}_pm";

    for ($self->{XS_DIR}, @{ $self->{glue_dirs} }) {
        my $file = "$_/$mod_pm";
        $mod_pm = $file if $complete;
        return $mod_pm if -e $file;
    }

    undef;
}

sub class_c_prefix {
    my $class = shift;
    $class =~ s/:/_/g;
    $class;
}

sub class_mpxs_prefix {
    my $class = shift;
    my $class_prefix = class_c_prefix($class);
    "mpxs_${class_prefix}_";
}

sub needs_prefix {
    my $name = shift;
    $name !~ /^(ap|apr|mpxs)_/i;
}

sub make_prefix {
    my ($name, $class) = @_;
    my $class_prefix = class_mpxs_prefix($class);
    return $name if $name =~ /^$class_prefix/;
    $class_prefix . $name;
}

sub isa_str {
    my ($self, $module) = @_;
    my $str = "";

    if (my $isa = $self->typemap->{function_map}->{isa}->{$module}) {
        foreach my $sub (sort keys %$isa) {
            my $base = $isa->{$sub};
#XXX cannot set isa in the BOOT: section because XSLoader local-ises
#ISA during bootstrap
#            $str .= qq{    av_push(get_av("$sub\::ISA", TRUE),
#                                   newSVpv("$base",0));}
            $str .= qq{\@$sub\::ISA = '$base';\n}
        }
    }

    $str;
}

sub boot {
    my ($self, $module) = @_;
    my $str = "";

    if (my $boot = $self->typemap->{function_map}->{boot}->{$module}) {
        $str = '    mpxs_' . $self->cname($module) . "_BOOT(aTHX);\n";
    }

    $str;
}

my $notshared = join '|', qw(TIEHANDLE); #not sure why yet

sub attrs {
    my ($self, $name) = @_;
    my $str = "";
    return $str if $name =~ /$notshared$/o;
    $str = "    ATTRS: unique\n" if GvUNIQUE;
    $str;
}

sub write_xs {
    my ($self, $module, $functions) = @_;

    my $fh = $self->open_class_file($module, '.xs');
    print $fh $self->ModPerl::Code::noedit_warning_c(), "\n";
    print $fh "\n#define MP_IN_XS\n\n";

    my @includes = @{ $self->includes };

    if (my $mod_h = $self->mod_h($module)) {
        push @includes, $mod_h;
    }

    for (@includes) {
        print $fh qq{\#include "$_"\n\n};
    }

    my $last_prefix = "";

    for my $func (@$functions) {
        my $class = $func->{class};
        my $prefix = $func->{prefix};
        $last_prefix = $prefix if $prefix;

        if ($func->{name} =~ /^mpxs_/) {
            #e.g. mpxs_Apache2__RequestRec_
            my $class_prefix = class_c_prefix($class);
            if ($func->{name} =~ /$class_prefix/) {
                $prefix = class_mpxs_prefix($class);
            }
        }

        $prefix = $prefix ? "  PREFIX = $prefix" : "";
        print $fh "MODULE = $module    PACKAGE = $class $prefix\n\n";

        print $fh $func->{code};
    }

    if (my $destructor = $self->typemap->destructor($last_prefix)) {
        my $arg = $destructor->{argspec}[0];

        print $fh <<EOF;
void
$destructor->{name}($arg)
    $destructor->{class} $arg

EOF
    }

    print $fh "MODULE = $module\n";
    print $fh "PROTOTYPES: disabled\n\n";
    print $fh "BOOT:\n";
    print $fh $self->boot($module);
    print $fh "    items = items; /* -Wall */\n\n";

    if (my $newxs = $self->{newXS}->{$module}) {
        for my $xs (sort { $a->[0] cmp $b->[0] } @$newxs) {
            print $fh qq{   cv = newXS("$xs->[0]", $xs->[1], __FILE__);\n};
            print $fh qq{   GvUNIQUE_on(CvGV(cv));\n} if GvUNIQUE;
        }
    }

    if ($module eq 'APR::Pool' && Apache2::Build::PERL_HAS_ITHREADS) {
        print $fh "    modperl_opt_interp_unselect = APR_RETRIEVE_OPTIONAL_FN(modperl_interp_unselect);\n\n";
        print $fh "    modperl_opt_thx_interp_get  = APR_RETRIEVE_OPTIONAL_FN(modperl_thx_interp_get);\n\n";
    }

    close $fh;
}

sub write_pm {
    my ($self, $module) = @_;

    my $isa = $self->isa_str($module);

    my $code = "";
    if (my $mod_pm = $self->mod_pm($module, 1)) {
        open my $fh, '<', $mod_pm;
        local $/;
        $code = <$fh>;
        close $fh;
    }

    my $base   = (split '::', $module)[0];
    unless (-e "lib/$base/XSLoader.pm") {
        $base = 'Apache2';
    }
    my $loader = join '::', $base, 'XSLoader';

    my $fh = $self->open_class_file($module, '.pm');
    my $noedit_warning = $self->ModPerl::Code::noedit_warning_hash();
    my $use_apr = ($module =~ /^APR::\w+$/) ? 'use APR ();' : '';
    my $version = module_version($module);

    print $fh <<EOF;
$noedit_warning

package $module;

use strict;
use warnings FATAL => 'all';

$isa
$use_apr
use $loader ();
our \$VERSION = '$version';
$loader\::load __PACKAGE__;

$code

1;
__END__
EOF
}

my %typemap = (
    'Apache2::RequestRec' => 'T_APACHEOBJ',
    'apr_time_t'         => 'T_APR_TIME',
    'APR::Table'         => 'T_HASHOBJ',
    'APR::Pool'          => 'T_POOLOBJ',
    'apr_size_t *'       => 'T_UVPTR',
);

sub write_typemap {
    my $self = shift;
    my $typemap = $self->typemap;
    my $map = $typemap->get;
    my %seen;

    my $fh = $self->open_class_file('ModPerl::WrapXS', 'typemap');
    print $fh $self->ModPerl::Code::noedit_warning_hash(), "\n";

    my %entries = ();
    my $max_key_len = 0;
    while (my ($type, $class) = each %$map) {
        $class ||= $type;
        next if $seen{$type}++ || $typemap->special($class);

        if ($class =~ /::/) {
            $entries{$class} = $typemap{$class} || 'T_PTROBJ';
            $max_key_len = length $class if length $class > $max_key_len;
        }
        else {
            $entries{$type} = $typemap{$type} || "T_$class";
            $max_key_len = length $type if length $type > $max_key_len;
        }
    }

    for (sort keys %entries) {
        printf $fh "%-${max_key_len}s %s\n", $_, $entries{$_};
    }

    close $fh;
}

sub write_typemap_h_file {
    my ($self, $method) = @_;

    $method = $method . '_code';
    my ($h, $code) = $self->typemap->$method();
    my $file = catfile $self->{XS_DIR}, $h;

    open my $fh, '>', $file or die "open $file: $!";
    print $fh $self->ModPerl::Code::noedit_warning_c(), "\n";
    print $fh $code;
    close $fh;
}

sub write_lookup_method_file {
    my $self = shift;

    my %map = ();
    foreach my $module (sort keys %{ $self->{XS} }) {
        my $functions = $self->{XS}->{$module};
        my $last_prefix = "";
        for my $func (@$functions) {
            my $class = $func->{class};
            my $prefix = $func->{prefix};
            $last_prefix = $prefix if $prefix;

            my $name = $func->{perl_name} || $func->{name};
            $name =~ s/^DEFINE_//;

            if ($name =~ /^mpxs_/) {
                #e.g. mpxs_Apache2__RequestRec_
                my $class_prefix = class_c_prefix($class);
                if ($name =~ /$class_prefix/) {
                    $prefix = class_mpxs_prefix($class);
                }
            }
            elsif ($name =~ /^ap_sub_req/) {
                $prefix = 'ap_sub_req_';
            }

            $name =~ s/^$prefix// if $prefix;

            push @{ $map{$name} }, [$module, $class];
        }

        # pure XS wrappers don't have the information about the
        # arguments they receive, since they manipulate the arguments
        # stack directly. therefore for these methods we can't tell
        # what are the objects they are invoked on
        for my $xs (@{ $self->{newXS}->{$module} || []}) {
            push @{ $map{$1} }, [$module, undef] if $xs->[0] =~ /.+::(.+)/;
        }
    }

    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$//;

    my $package = "ModPerl::MethodLookup";
    my $file = catfile "lib", "ModPerl", "MethodLookup.pm";
    debug "creating $file";
    open my $fh, ">$file" or die "Can't open $file: $!";

    my $noedit_warning = $self->ModPerl::Code::noedit_warning_hash();

    print $fh <<EOF;
$noedit_warning
package $package;

use strict;
use warnings;

my \$methods = $methods;

EOF

    print $fh <<'EOF';

use base qw(Exporter);
use mod_perl2;

our @EXPORT = qw(print_method print_module print_object);
our $VERSION = $mod_perl2::VERSION;
use constant MODULE => 0;
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} }) {
            next unless defined $item->[OBJECT];
            push @{ $objects->{$item->[OBJECT]} }, [$method, $item->[MODULE]];
        }
    }
}

# if there is only one replacement method in 2.0 API we can
# automatically lookup it, up however if there are more than one
# (e.g. new()), we need to use a fully qualified value here
# of course the same if the package is not a mod_perl one.
#
# the first field represents the replacement method or undef if none
# exists, the second field is for extra comments (e.g. when there is
# no replacement method)
my $methods_compat = {
    # Apache2::
    gensym            => ['Symbol::gensym',
                          'or use "open my $fh, $file"'],
    module            => ['Apache2::Module::loaded',
                          ''],
    define            => ['exists_config_define',
                          ''],
    httpd_conf        => ['add_config',
                          ''],
    SERVER_VERSION    => ['get_server_version',
                          ''],
    can_stack_handlers=> [undef,
                          'there is no more need for that method in mp2'],

    # Apache2::RequestRec
    soft_timeout      => [undef,
                          'there is no more need for that method in mp2'],
    hard_timeout      => [undef,
                          'there is no more need for that method in mp2'],
    kill_timeout      => [undef,
                          'there is no more need for that method in mp2'],
    reset_timeout     => [undef,
                          'there is no more need for that method in mp2'],
    cleanup_for_exec  => [undef,
                          'there is no more need for that method in mp2'],
    send_http_header  => ['content_type',
                          ''],
    header_in         => ['headers_in',
                          'this method works in mod_perl 1.0 too'],
    header_out        => ['headers_out',
                          'this method works in mod_perl 1.0 too'],
    err_header_out    => ['err_headers_out',
                          'this method works in mod_perl 1.0 too'],
    register_cleanup  => ['cleanup_register',
                          ''],
    post_connection   => ['cleanup_register',
                          ''],
    content           => [undef, # XXX: Apache2::Request::what?
                          'use CGI.pm or Apache2::Request instead'],
    clear_rgy_endav   => ['special_list_clear',
                          ''],
    stash_rgy_endav   => [undef,
                          ''],
    run_rgy_endav     => ['special_list_call',
                          'this method is no longer needed'],
    seqno             => [undef,
                          'internal to mod_perl 1.0'],
    chdir_file        => [undef, # XXX: to be resolved
                          'temporary unavailable till the issue with chdir' .
                          ' in the threaded env is resolved'],
    log_reason        => ['log_error',
                          'not in the Apache 2.0 API'],
    READLINE          => [undef, # XXX: to be resolved
                          ''],
    send_fd_length    => [undef,
                          'not in the Apache 2.0 API'],
    send_fd           => ['sendfile',
                          'requires an offset argument'],
    is_main           => ['main',
                          'not in the Apache 2.0 API'],
    cgi_var           => ['subprocess_env',
                          'subprocess_env can be used with mod_perl 1.0'],
    cgi_env           => ['subprocess_env',
                          'subprocess_env can be used with mod_perl 1.0'],
    each_byterange    => [undef,
                          'now handled internally by ap_byterange_filter'],
    set_byterange     => [undef,
                          'now handled internally by ap_byterange_filter'],

    # Apache::File
    open              => [undef,
                          ''],
    close             => [undef, # XXX: also defined in APR::Socket
                          ''],
    tmpfile           => [undef,
                          'not in the Apache 2.0 API, ' .
                          'use File::Temp instead'],

    # Apache::Util
    size_string       => ['format_size',
                          ''],
    escape_uri        => ['unescape_path',
                          ''],
    escape_url        => ['escape_path',
                          'and requires a pool object'],
    unescape_uri      => ['unescape_url',
                          ''],
    unescape_url_info => [undef,
                          'use CGI::Util::unescape() instead'],
    escape_html       => [undef, # XXX: will be ap_escape_html
                          'ap_escape_html now requires a pool object'],
    parsedate         => ['parse_http',
                          ''],
    validate_password => ['password_validate',
                          ''],

    # Apache::Table
    #new               => ['make',
    #                      ''], # XXX: there are other 'new' methods

    # Apache::Connection
    auth_type         => ['ap_auth_type',
                          'now resides in the request object'],
};

sub avail_methods_compat {
    return keys %$methods_compat;
}

sub avail_methods {
    return keys %$methods;
}

sub avail_modules {
    my %modules = ();
    for my $method (keys %$methods) {
        for my $item ( @{ $methods->{$method} }) {
            $modules{$item->[MODULE]}++;
        }
    }
    return keys %modules;
}

sub preload_all_modules {
    _get_modules() unless $modules;
    eval "require $_" for sort 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] =~ /^(Apache2|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. Inheritance is supported.
sub lookup_method {
    my ($method, $object) = @_;

    unless (defined $method) {
        my $hint = "No 'method' argument was passed\n";
        return ($hint);
    }

    # strip the package name for the fully qualified method
    $method =~ s/.+:://;

    if (exists $methods_compat->{$method}) {
        my ($replacement, $comment) = @{$methods_compat->{$method}};
        my $hint = "'$method' is not a part of the mod_perl 2.0 API\n";
        $comment = length $comment ? " $comment\n" : "";

        # some removed methods have no replacement
        return $hint . "$comment" unless defined $replacement;

        $hint .= "use '$replacement' instead. $comment";

        # if fully qualified don't look up its container
        return $hint if $replacement =~ /::/;

        my ($modules_hint, @modules) = lookup_method($replacement, $object);
        return $hint . $modules_hint;
    }
    elsif (!exists $methods->{$method}) {
        my $hint = "Don't know anything about method '$method'\n";
        return ($hint);
    }

    my @items = @{ $methods->{$method} };
    if (@items == 1) {
        my $module = $items[0]->[MODULE];
        my $hint = "To use method '$method' add:\n" . "\tuse $module ();\n";
        # we should really check that the method matches the object if
        # any was passed, but it may not always work
        return ($hint, $module);
    }
    else {
        if (defined $object) {
            my $class = ref $object || $object;
            for my $item (@items) {
                # real class or inheritance
                if ($class eq $item->[OBJECT] or
                    (ref($object) && $object->isa($item->[OBJECT]))) {
                    my $module = $item->[MODULE];
                    my $hint = "To use method '$method' add:\n" .
                        "\tuse $module ();\n";
                    return ($hint, $module);
                }
            }
            # fall-through
            local $" = ", ";
            my @modules = map $_->[MODULE], @items;
            my $hint = "Several modules (@modules) contain method '$method' " .
                "but none of them matches class '$class';\n";
            return ($hint);

        }
        else {
            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 Apache2::Filter)
            my @modules = sort 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;
EOF
    close $fh;
}

sub write_module_versions_file {
    my $self = shift;

    my $file = catfile "lib", "ModPerl", "DummyVersions.pm";
    debug "creating $file";
    open my $fh, ">$file" or die "Can't open $file: $!";

    my $noedit_warning = $self->ModPerl::Code::noedit_warning_hash();
    print $fh "$noedit_warning\n";

    my @modules = keys %{ $self->{XS} };
    push @modules, qw(ModPerl::MethodLookup);

    my $len = 0;
    for (@modules) {
        $len = length $_ if length $_ > $len;
    }

    require mod_perl2;
    $len += length '$::VERSION';
    for (sort @modules) {
        my $ver = module_version($_);
        printf $fh "package %s;\n%-${len}s = %s;\n\n",
            $_, '$'.$_."::VERSION", $ver;
    }
}

sub generate {
    my $self = shift;

    $self->prepare;

    for (qw(ModPerl::WrapXS Apache2 APR ModPerl)) {
        $self->write_makefilepl($_);
    }

    $self->write_typemap;

    for (qw(typedefs sv_convert)) {
        $self->write_typemap_h_file($_);
    }

    $self->get_functions;
    $self->get_structures;
    $self->write_export_file('exp') if Apache2::Build::AIX;
    $self->write_export_file('def') if Apache2::Build::WIN32;

    foreach my $module (sort keys %{ $self->{XS} }) {
        my $functions = $self->{XS}->{$module};
#        my ($root, $sub) = split '::', $module;
#        if (-e "$self->{XS_DIR}/$root/$sub/$sub.xs") {
#            $module = join '::', $root, "Wrap$sub";
#        }
        $self->write_makefilepl($module);
        $self->write_xs($module, $functions);
        $self->write_pm($module);
    }

    $self->write_lookup_method_file;
    $self->write_module_versions_file;
}

#three .sym files are generated:
#global   - global symbols
#ithreads - #ifdef USE_ITHREADS functions
#inline   - __inline__ functions
#the inline symbols are needed #ifdef MP_DEBUG
#since __inline__ will be turned off

my %multi_export = map { $_, 1 } qw(exp);

sub open_export_files {
    my ($self, $name, $ext) = @_;

    my $dir = $self->{XS_DIR};
    my %handles;
    my @types = qw(global inline ithreads);

    if ($multi_export{$ext}) {
        #write to multiple files
        for my $type (@types) {
            my $file = "$dir/${name}_$type.$ext";

            open my $fh, '>', $file or
              die "open $file: $!";

            $handles{$type} = $fh;
        }
    }
    else {
        #write to one file
        my $file = "$dir/$name.$ext";

        open my $fh, '>', $file or
          die "open $file: $!";

        for my $type (@types) {
            $handles{$type} = $fh;
        }
    }

    \%handles;
}

sub func_is_static {
    my ($self, $entry) = @_;
    if (my $attr = $entry->{attr}) {
        return 1 if grep { $_ eq 'static' } @$attr;
    }

    #C::Scan doesnt always pickup static __inline__
    return 1 if $entry->{name} =~ /^mpxs_/o;

    return 0;
}

sub func_is_inline {
    my ($self, $entry) = @_;
    if (my $attr = $entry->{attr}) {
        return 1 if grep { $_ eq '__inline__' } @$attr;
    }
    return 0;
}

sub export_file_header_exp {
    my $self = shift;
    "#!\n";
}

sub export_file_format_exp {
    my ($self, $val) = @_;
    "$val\n";
}

sub export_file_header_def {
    my $self = shift;
    "LIBRARY\n\nEXPORTS\n\n";
}

sub export_file_format_def {
    my ($self, $val) = @_;
    "   $val\n";
}

my $ithreads_exports = join '|', qw{
modperl_cmd_interp_
modperl_interp_
modperl_list_
modperl_tipool_
modperl_svptr_table_clone$
modperl_mgv_require_module$
};

sub export_func_handle {
    my ($self, $entry, $handles) = @_;

    if ($self->func_is_inline($entry)) {
        return $handles->{inline};
    }
    elsif ($entry->{name} =~ /^($ithreads_exports)/) {
        return $handles->{ithreads};
    }

    $handles->{global};
}

sub write_export_file {
    my ($self, $ext) = @_;

    my %files = (
        modperl => $ModPerl::FunctionTable,
        apache2 => $Apache2::FunctionTable,
        apr     => $APR::FunctionTable,
    );

    my $header = \&{"export_file_header_$ext"};
    my $format = \&{"export_file_format_$ext"};

    foreach my $key (sort keys %files) {
        my $table = $files{$key};
        my $handles = $self->open_export_files($key, $ext);

        my %seen; #only write header once if this is a single file
        for my $fh (values %$handles) {
            next if $seen{$fh}++;
            print $fh $self->$header();
        }

        # add the symbols which aren't the function table
        if ($key eq 'modperl') {
            my $fh = $handles->{global};
            for my $name (@global_structs) {
                print $fh $self->$format($name);
            }
        }

        for my $entry (@$table) {
            next if $self->func_is_static($entry);
            my $name = $entry->{name};

            my $fh = $self->export_func_handle($entry, $handles);

            print $fh $self->$format($name);
        }

        %seen = (); #only close handle once if this is a single file
        for my $fh (values %$handles) {
            next if $seen{$fh}++;
            close $fh;
        }
    }
}

sub stats {
    my $self = shift;

    $self->get_functions;
    $self->get_structures;

    my %stats;

    while (my ($module, $functions) = each %{ $self->{XS} }) {
        $stats{$module} += @$functions;
        if (my $newxs = $self->{newXS}->{$module}) {
            $stats{$module} += @$newxs;
        }
    }

    return \%stats;
}

sub generate_exports {
    my ($self, $fh) = @_;

    if (!$build->should_build_apache) {
        print $fh <<"EOF";
/* This is intentionnaly left blank, only usefull for static build */
const void *modperl_ugly_hack = NULL;
EOF
        return;
    }

    print $fh <<"EOF";
/*
 * This is indeed a ugly hack!
 * See also src/modules/perl/mod_perl.c for modperl_ugly_hack
 * If we don't build such a list of exported API functions, the over-zealous
 * linker can and will remove the unused functions completely. In order to
 * avoid this, we create this object and modperl_ugly_hack to create a
 * dependency between all the exported API and mod_perl.c
 */
const void *modperl_ugly_hack = NULL;
EOF

    for my $entry (@$ModPerl::FunctionTable) {
        next if $self->func_is_static($entry);
        unless (Apache2::Build::PERL_HAS_ITHREADS) {
            next if $entry->{name} =~ /^($ithreads_exports)/;
        }
        ( my $name ) = $entry->{name} =~ /^modperl_(.*)/;
        print $fh <<"EOF";
#ifndef modperl_$name
const void *modperl_hack_$name = (const void *)modperl_$name;
#endif

EOF
    }
}

1;
__END__