# 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::Code;

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

use Config;
use File::Spec::Functions qw(catfile catdir);

use mod_perl2 ();
use Apache2::Build ();

use Apache::TestConfig ();
use Apache::TestTrace;

our $VERSION = '0.01';
our @ISA = qw(Apache2::Build);

my %handlers = (
    Process    => [qw(ChildInit ChildExit)], #Restart PreConfig
    Files      => [qw(OpenLogs PostConfig)],
    PerSrv     => [qw(PostReadRequest Trans MapToStorage)],
    PerDir     => [qw(HeaderParser
                      Access Authen Authz
                      Type Fixup Response Log Cleanup
                      InputFilter OutputFilter)],
    Connection => [qw(ProcessConnection)],
    PreConnection => [qw(PreConnection)],
);

my %hooks = map { $_, canon_lc($_) }
    map { @{ $handlers{$_} } } keys %handlers;

my %not_ap_hook = map { $_, 1 } qw(child_exit response cleanup
                                   output_filter input_filter);

my %not_request_hook = map { $_, 1 } qw(child_init process_connection
                                        pre_connection open_logs post_config);

my %hook_proto = (
    Process    => {
        ret  => 'void',
        args => [{type => 'apr_pool_t', name => 'p'},
                 {type => 'server_rec', name => 's'},
                 {type => 'dummy', name => 'MP_HOOK_VOID'}],
    },
    Files      => {
        ret  => 'int',
        args => [{type => 'apr_pool_t', name => 'pconf'},
                 {type => 'apr_pool_t', name => 'plog'},
                 {type => 'apr_pool_t', name => 'ptemp'},
                 {type => 'server_rec', name => 's'},
                 {type => 'dummy', name => 'MP_HOOK_RUN_ALL'}],
    },
    PerSrv     => {
        ret  => 'int',
        args => [{type => 'request_rec', name => 'r'},
                 {type => 'dummy', name => 'MP_HOOK_RUN_ALL'}],
    },
    Connection => {
        ret  => 'int',
        args => [{type => 'conn_rec', name => 'c'},
                 {type => 'dummy', name => 'MP_HOOK_RUN_FIRST'}],
    },
    PreConnection => {
        ret  => 'int',
        args => [{type => 'conn_rec', name => 'c'},
                 {type => 'void', name => 'csd'},
                 {type => 'dummy', name => 'MP_HOOK_RUN_ALL'}],
    },
);

my %cmd_push = (
    InputFilter  => 'modperl_cmd_push_filter_handlers',
    OutputFilter => 'modperl_cmd_push_filter_handlers',
);
my $cmd_push_default = 'modperl_cmd_push_handlers';
sub cmd_push {
    $cmd_push{+shift} || $cmd_push_default;
}

$hook_proto{PerDir} = $hook_proto{PerSrv};

my $scfg_get = 'MP_dSCFG(parms->server)';

my $dcfg_get = "$scfg_get;\n" .
  '    modperl_config_dir_t *dcfg = (modperl_config_dir_t *)dummy';

my %directive_proto = (
    PerSrv     => {
        args => [{type => 'cmd_parms', name => 'parms'},
                 {type => 'void', name => 'dummy'},
                 {type => 'const char', name => 'arg'}],
        cfg  => {get => $scfg_get, name => 'scfg'},
        scope => 'RSRC_CONF',
    },
    PerDir     => {
        args => [{type => 'cmd_parms', name => 'parms'},
                 {type => 'void', name => 'dummy'},
                 {type => 'const char', name => 'arg'}],
        cfg  => {get => $dcfg_get, name => 'dcfg'},
        scope => 'OR_ALL',
    },
);

for my $class (qw(Process Connection PreConnection Files)) {
    $directive_proto{$class}->{cfg}->{name} = 'scfg';
    $directive_proto{$class}->{cfg}->{get} = $scfg_get;

    for (qw(args scope)) {
        $directive_proto{$class}->{$_} = $directive_proto{PerSrv}->{$_};
    }
}

while (my ($k,$v) = each %directive_proto) {
    $directive_proto{$k}->{ret} = 'const char *';
    my $handlers = join '_', 'handlers', canon_lc($k);
    $directive_proto{$k}->{handlers} =
      join '->', $directive_proto{$k}->{cfg}->{name}, $handlers;
}

#XXX: allow disabling of PerDir hooks on a PerDir basis
my @hook_flags = (map { canon_uc($_) } keys %hooks);
my @ithread_opts = qw(CLONE PARENT);
my %flags = (
    Srv => ['NONE', @ithread_opts, qw(ENABLE AUTOLOAD MERGE_HANDLERS),
            @hook_flags, 'UNSET','INHERIT_SWITCHES'],
    Dir => [qw(NONE PARSE_HEADERS SETUP_ENV MERGE_HANDLERS GLOBAL_REQUEST UNSET)],
    Req => [qw(NONE SET_GLOBAL_REQUEST PARSE_HEADERS SETUP_ENV
               CLEANUP_REGISTERED PERL_SET_ENV_DIR PERL_SET_ENV_SRV)],
    Interp => [qw(NONE IN_USE CLONED BASE)],
    Handler => [qw(NONE PARSED METHOD OBJECT ANON AUTOLOAD DYNAMIC FAKE)],
);

$flags{DirSeen} = $flags{Dir};

my %flags_options = map { $_,1 } qw(Srv Dir);

my %flags_field = (
    DirSeen => 'flags->opts_seen',
    (map { $_, 'flags->opts' } keys %flags_options),
);

sub new {
    my $class = shift;
    bless {
       handlers        => \%handlers,
       hook_proto      => \%hook_proto,
       directive_proto => \%directive_proto,
       flags           => \%flags,
       path            => 'src/modules/perl',
    }, $class;
}

sub path { shift->{path} }

sub handler_desc {
    my ($self, $h_add, $c_add) = @_;
    local $" = ",\n";
    while (my ($class, $h) = each %{ $self->{handler_index_desc} }) {
        my $func = canon_func('handler', 'desc', $class);
        my $array = join '_', 'MP', $func;
        my $proto = "const char *$func(int idx)";

        $$h_add .= "$proto;\n";

        $$c_add .= <<EOF;
static const char * $array [] = {
@{ [ map { $_ ? qq(    "$_") : '    NULL' } @$h, '' ] }
};

$proto
{
    return $array [idx];
}

EOF
    }
}

sub generate_handler_index {
    my ($self, $h_fh) = @_;

    my $type = 1;

    while (my ($class, $handlers) = each %{ $self->{handlers} }) {
        my $i = 0;
        my $n = @$handlers;
        my $handler_type = canon_define('HANDLER_TYPE', $class);

        print $h_fh "\n#define ",
          canon_define('HANDLER_NUM', $class), " $n\n\n";

        print $h_fh "#define $handler_type $type\n\n";

        $type++;

        for my $name (@$handlers) {
            my $define = canon_define($name, 'handler');
            $self->{handler_index}->{$class}->[$i] = $define;
            $self->{handler_index_type}->{$class}->[$i] = $handler_type;
            $self->{handler_index_desc}->{$class}->[$i] = "Perl${name}Handler";
            print $h_fh "#define $define $i\n";
            $i++;
        }
    }
}

sub generate_handler_hooks {
    my ($self, $h_fh, $c_fh) = @_;

    my @register_hooks;

    while (my ($class, $prototype) = each %{ $self->{hook_proto} }) {
        my $callback = canon_func('callback', $class);
        my $return = $prototype->{ret} eq 'void' ? '' : 'return';
        my $i = -1;

        for my $handler (@{ $self->{handlers}{$class} }) {
            my $name = canon_func($handler, 'handler');
            $i++;

            if (my $hook = $hooks{$handler}) {
                next if $not_ap_hook{$hook};

                my $order = $not_request_hook{$hook} ? 'APR_HOOK_FIRST'
                                                     : 'APR_HOOK_REALLY_FIRST';

                push @register_hooks,
                  "    ap_hook_$hook($name, NULL, NULL, $order);";
            }

            my ($protostr, $pass) = canon_proto($prototype, $name);
            my $ix = $self->{handler_index}->{$class}->[$i];

            if ($callback =~ m/modperl_callback_per_(dir|srv)/) {
                if ($ix =~ m/AUTH|TYPE|TRANS|MAP/) {
                    $pass =~ s/MP_HOOK_RUN_ALL/MP_HOOK_RUN_FIRST/;
                }
            }

            print $h_fh "\n$protostr;\n";

            print $c_fh <<EOF;
$protostr
{
    $return $callback($ix, $pass);
}

EOF
        }
    }

    local $" = "\n";
    my $hooks_proto = 'void modperl_register_handler_hooks(void)';
    my $h_add = "$hooks_proto;\n";
    my $c_add = "$hooks_proto {\n@register_hooks\n}\n";

    $self->handler_desc(\$h_add, \$c_add);

    return ($h_add, $c_add);
}

sub generate_handler_find {
    my ($self, $h_fh, $c_fh) = @_;

    my $proto = 'int modperl_handler_lookup(const char *name, int *type)';
    my (%ix, %switch);

    print $h_fh "$proto;\n";

    print $c_fh <<EOF;
$proto
{
    if (*name == 'P' && strnEQ(name, "Perl", 4)) {
        name += 4;
    }

    switch (*name) {
EOF

    while (my ($class, $handlers) = each %{ $self->{handlers} }) {
        my $i = 0;

        for my $name (@$handlers) {
            $name =~ /^([A-Z])/;
            push @{ $switch{$1} }, $name;
            $ix{$name}->{name} = $self->{handler_index}->{$class}->[$i];
            $ix{$name}->{type} = $self->{handler_index_type}->{$class}->[$i++];
        }
    }

    for my $key (sort keys %switch) {
        my $names = $switch{$key};
        print $c_fh "      case '$key':\n";

        #support $r->push_handlers(PerlHandler => ...)
        if ($key eq 'H') {
            print $c_fh <<EOF;
          if (strEQ(name, "Handler")) {
              *type = $ix{'Response'}->{type};
              return $ix{'Response'}->{name};
          }
EOF
        }

        for my $name (@$names) {
            my $n = length($name);
            print $c_fh <<EOF;
          if (strnEQ(name, "$name", $n)) {
              *type = $ix{$name}->{type};
              return $ix{$name}->{name};
          }
EOF
        }
    }

    print $c_fh "    };\n    return -1;\n}\n";

    return ("", "");
}

sub generate_handler_directives {
    my ($self, $h_fh, $c_fh) = @_;

    my @cmd_entries;

    while (my ($class, $handlers) = each %{ $self->{handlers} }) {
        my $prototype = $self->{directive_proto}->{$class};
        my $i = 0;

        for my $h (@$handlers) {
            my $h_name = join $h, qw(Perl Handler);
            my $name = canon_func('cmd', $h, 'handlers');
            my $cmd_name = canon_define('cmd', $h, 'entry');
            my $protostr = canon_proto($prototype, $name);
            my $flag = 'MpSrv' . canon_uc($h);
            my $ix = $self->{handler_index}->{$class}->[$i++];
            my $av = "$prototype->{handlers} [$ix]";
            my $cmd_push = cmd_push($h);

            print $h_fh "$protostr;\n";

            push @cmd_entries, $cmd_name;

            print $h_fh <<EOF;

#define $cmd_name \\
AP_INIT_ITERATE("$h_name", $name, NULL, \\
 $prototype->{scope}, "Subroutine name")

EOF
            print $c_fh <<EOF;

$protostr
{
    $prototype->{cfg}->{get};
    if (!MpSrvENABLE(scfg)) {
        return apr_pstrcat(parms->pool,
                           "Perl is disabled for server ",
                           parms->server->server_hostname, NULL);
    }
    if (!$flag(scfg)) {
        return apr_pstrcat(parms->pool,
                           "$h_name is disabled for server ",
                           parms->server->server_hostname, NULL);
    }
    MP_TRACE_d(MP_FUNC, "push \@%s, %s", parms->cmd->name, arg);
    return $cmd_push(&($av), arg, parms->pool);
}
EOF
        }
    }

    my $h_add =  '#define MP_CMD_ENTRIES \\' . "\n" . join ', \\'."\n", @cmd_entries;

    return ($h_add, "");
}

sub generate_flags {
    my ($self, $h_fh, $c_fh) = @_;

    my $n = 1;

    (my $dlsrc = uc $Config{dlsrc}) =~ s/\.xs$//i;

    print $h_fh "\n#define MP_SYS_$dlsrc 1\n";

    while (my ($class, $opts) = each %{ $self->{flags} }) {
        my @lookup = ();
        my %lookup = ();
        my $lookup_proto = "";
        my %dumper;
        if ($flags_options{$class}) {
            $lookup_proto = join canon_func('flags', 'lookup', $class),
              'U32 ', '(const char *str)';
            push @lookup, "$lookup_proto {";
        }

        my $flags = join $class, qw(Mp FLAGS);
        my $field = $flags_field{$class} || 'flags';

        print $h_fh "\n#define $flags(p) (p)->$field\n";

        $class = "Mp$class";
        print $h_fh "\n#define ${class}Type $n\n";
        $n++;

        my $i = 0;
        my $max_len = 0;
        for my $f (@$opts) {
            my $x = sprintf "0x%08x", $i;
            my $flag = "${class}_f_$f";
            my $cmd  = $class . $f;
            my $name = canon_name($f);
            $lookup{$name} = $flag;
            $max_len = length $name if $max_len < length $name;
            print $h_fh <<EOF;

/* $f */
#define $flag $x
#define $cmd(p)  ($flags(p) & $flag)
#define ${cmd}_On(p)  ($flags(p) |= $flag)
#define ${cmd}_Off(p) ($flags(p) &= ~$flag)

EOF
            $dumper{$name} =
              qq{modperl_trace(NULL, " $name %s", \\
                         ($flags(p) & $x) ? "On " : "Off");};

            $i += $i || 1;
        }
        if (@lookup) {
            my $indent1 = " " x 4;
            my $indent2 = " " x 8;
            my %switch = ();
            for (keys %lookup) {
                if (/^(\w)/) {
                    my $gap = " " x ($max_len - length $_);
                    push @{ $switch{$1} },
                        qq{if (strEQ(str, "$_"))$gap return $lookup{$_};};
                }
            }

            push @lookup, '', $indent1 . "switch (*str) {";
            for (keys %switch) {
                push @lookup, $indent1 . "  case '$_':";
                push @lookup, map { $indent2 . $_ } @{ $switch{$_} };
            }
            push @lookup, map { $indent1 . $_ } ("}\n", "return -1;\n}\n\n");

            print $c_fh join "\n", @lookup;
            print $h_fh "$lookup_proto;\n";
        }

        delete $dumper{None}; #NONE
        print $h_fh join ' \\'."\n",
          "#define ${class}_dump_flags(p, str)",
                     qq{modperl_trace(NULL, "$class flags dump (%s):", str);},
                     map $dumper{$_}, sort keys %dumper;
    }

    print $h_fh "\n#define MpSrvHOOKS_ALL_On(p) MpSrvFLAGS(p) |= (",
      (join '|', map { 'MpSrv_f_' . $_ } @hook_flags), ")\n";

    print $h_fh "\n#define MpSrvOPT_ITHREAD_ONLY(o) \\\n",
      (join ' || ', map("(o == MpSrv_f_$_)", @ithread_opts)), "\n";

    ();
}

my %trace = (
    'a' => 'Apache API interaction',
    'c' => 'configuration for directive handlers',
    'd' => 'directive processing',
    'e' => 'environment variables',
    'f' => 'filters',
    'g' => 'globals management',
    'h' => 'handlers',
    'i' => 'interpreter pool management',
    'm' => 'memory allocations',
    'o' => 'I/O',
    'r' => 'Perl runtime interaction',
    's' => 'Perl sections',
    't' => 'benchmark-ish timings',
);

sub generate_trace {
    my ($self, $h_fh) = @_;

    my $v     = $self->{build}->{VERSION};
    my $api_v = $self->{build}->{API_VERSION};

    print $h_fh qq(#define MP_VERSION_STRING "mod_perl/$v"\n);

    # this needs to be a string, not an int, because of the
    # macro definition.  patches welcome.
    print $h_fh qq(#define MP_API_VERSION "$api_v"\n);

    my $i = 1;
    my @trace = sort keys %trace;
    my $opts = join '', @trace;
    my $tl = "MP_debug_level";

    print $h_fh <<EOF;
#define MP_TRACE_OPTS "$opts"

#ifdef MP_TRACE
#define MP_TRACE_any if ($tl) modperl_trace
#define MP_TRACE_any_do(exp) if ($tl) { \\
exp; \\
}
#else
#define MP_TRACE_any if (0) modperl_trace
#define MP_TRACE_any_do(exp)
#endif

EOF

    my @dumper;
    for my $type (sort @trace) {
        my $define = "#define MP_TRACE_$type";
        my $define_do = join '_', $define, 'do';

        print $h_fh <<EOF;
#ifdef MP_TRACE
$define if ($tl & $i) modperl_trace
$define_do(exp) if ($tl & $i) { \\
exp; \\
}
#else
$define if (0) modperl_trace
$define_do(exp)
#endif
EOF
        push @dumper,
          qq{modperl_trace(NULL, " $type %s ($trace{$type})", ($tl & $i) ? "On " : "Off");};
        $i += $i;
    }

    print $h_fh join ' \\'."\n",
                     '#define MP_TRACE_dump_flags()',
                     qq{modperl_trace(NULL, "mod_perl trace flags dump:");},
                     @dumper;

    ();
}

sub generate_largefiles {
    my ($self, $h_fh) = @_;

    my $flags = $self->perl_config('ccflags_uselargefiles');

    return unless $flags;

    for my $flag (split /\s+/, $flags) {
        next if $flag =~ /^-/; # skip -foo flags
        my ($name, $val) = split '=', $flag;
        $val ||= '';
        $name =~ s/^-D//;
        print $h_fh "#define $name $val\n";
    }
}

sub ins_underscore {
    $_[0] =~ s/([a-z])([A-Z])/$1_$2/g;
    $_[0] =~ s/::/_/g;
}

sub canon_uc {
    my $s = shift;
    ins_underscore($s);
    uc $s;
}

sub canon_lc {
    my $s = shift;
    ins_underscore($s);
    lc $s;
}

sub canon_func {
    join '_', 'modperl', map { canon_lc($_) } @_;
}

sub canon_name {
    local $_ = shift;
    s/([A-Z]+)/ucfirst(lc($1))/ge;
    s/_//g;
    $_;
}

sub canon_define {
    join '_', 'MP', map { canon_uc($_) } @_;
}

sub canon_args {
    my $args = shift->{args};
    my @pass = map { $_->{name} } @$args;
    my @in;
    foreach my $href (@$args) {
        push @in, "$href->{type} *$href->{name}"
            unless $href->{type} eq 'dummy';
    }
    return wantarray ? (\@in, \@pass) : \@in;
}

sub canon_proto {
    my ($prototype, $name) = @_;
    my ($in,$pass) = canon_args($prototype);

    local $" = ', ';

    my $p = "$prototype->{ret} $name(@$in)";
    $p =~ s/\* /*/;
    return wantarray ? ($p, "@$pass") : $p;
}

my %sources = (
   generate_handler_index      => {h => 'modperl_hooks.h'},
   generate_handler_hooks      => {h => 'modperl_hooks.h',
                                   c => 'modperl_hooks.c'},
   generate_handler_directives => {h => 'modperl_directives.h',
                                   c => 'modperl_directives.c'},
   generate_handler_find       => {h => 'modperl_hooks.h',
                                   c => 'modperl_hooks.c'},
   generate_flags              => {h => 'modperl_flags.h',
                                   c => 'modperl_flags.c'},
   generate_trace              => {h => 'modperl_trace.h'},
   generate_largefiles         => {h => 'modperl_largefiles.h'},
   generate_constants          => {h => 'modperl_constants.h',
                                   c => 'modperl_constants.c'},
   generate_exports            => {c => 'modperl_exports.c'},
);

my @c_src_names = qw(interp tipool log config cmd options callback handler
                     gtop util io io_apache filter bucket mgv pcw global env
                     cgi perl perl_global perl_pp sys module svptr_table
                     const constants apache_compat error debug
                     common_util common_log);
my @h_src_names = qw(perl_unembed);
my @g_c_names = map { "modperl_$_" } qw(hooks directives flags xsinit exports);
my @c_names   = ('mod_perl', (map "modperl_$_", @c_src_names));
sub c_files { [map { "$_.c" } @c_names, @g_c_names] }
sub o_files { [map { "$_.o" } @c_names, @g_c_names] }
sub o_pic_files { [map { "$_.lo" } @c_names, @g_c_names] }

my @g_h_names = map { "modperl_$_" } qw(hooks directives flags trace
                                        largefiles);
my @h_names = (@c_names, map { "modperl_$_" } @h_src_names,
               qw(types time apache_includes perl_includes apr_includes
                  apr_compat common_includes common_types));
sub h_files { [map { "$_.h" } @h_names, @g_h_names] }

sub clean_files {
    my @c_names = @g_c_names;
    my @h_names = @g_h_names;

    for (\@c_names, \@h_names) {
        push @$_, 'modperl_constants';
    }

    [(map { "$_.c" } @c_names), (map { "$_.h" } @h_names)];
}

sub classname {
    my $self = shift || __PACKAGE__;
    ref($self) || $self;
}

sub noedit_warning_c {
    my $class = classname(shift);

    my $v = join '/', $class, $class->VERSION;
    my $trace = Apache::TestConfig::calls_trace();
    $trace =~ s/^/ * /mg;
    return <<EOF;

/*
 * *********** WARNING **************
 * This file generated by $v
 * Any changes made here will be lost
 * ***********************************
$trace */

EOF
}

#this is named hash after the `#' character
#rather than named perl, since #comments are used
#non-Perl files, e.g. Makefile, typemap, etc.
sub noedit_warning_hash {
    my $class = classname(shift);

    (my $warning = noedit_warning_c($class)) =~ s/^/\# /mg;
    return $warning;
}

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

    return unless $name;
    return if $self->{init_files}->{$name}++;

    my (@preamble);
    if ($name =~ /\.h$/) {
        (my $d = uc $name) =~ s/\./_/;
        push @preamble, "#ifndef $d\n#define $d\n";
        push @{ $self->{postamble}->{$name} }, "\n#endif /* $d */\n";
    }
    elsif ($name =~ /\.c/) {
        push @preamble, qq{\#include "mod_perl.h"\n\n};
    }

    my $file = "$self->{path}/$name";
    debug "generating...$file";
    unlink $file;
    open my $fh, '>>', $file or die "open $file: $!";
    print $fh @preamble, noedit_warning_c();

    $self->{fh}->{$name} = $fh;
}

sub fh {
    my ($self, $name) = @_;
    return unless $name;
    $self->{fh}->{$name};
}

sub postamble {
    my $self = shift;
    for my $name (keys %{ $self->{fh} }) {
        next unless my $av = $self->{postamble}->{$name};
        print { $self->fh($name) } @$av;
    }
}

sub generate {
    my ($self, $build) = @_;

    $self->{build} = $build;

    for my $s (values %sources) {
        for (qw(h c)) {
            $self->init_file($s->{$_});
        }
    }

    for my $method (reverse sort keys %sources) {
        my ($h_fh, $c_fh) = map {
            $self->fh($sources{$method}->{$_});
        } qw(h c);
        my ($h_add, $c_add) = $self->$method($h_fh, $c_fh);
        if ($h_add) {
            print $h_fh $h_add;
        }
        if ($c_add) {
            print $c_fh $c_add;
        }
        debug "$method...done";
    }

    $self->postamble;

    my $xsinit = "$self->{path}/modperl_xsinit.c";
    debug "generating...$xsinit";

    # There's a possibility that $Config{static_ext} may contain spaces
    # and ExtUtils::Embed::xsinit won't handle the situation right. In
    # this case we'll get buggy "boot_" statements in modperl_xsinit.c.
    # Fix this by cleaning the @Extensions array.

    # Loads @Extensions if not loaded
    ExtUtils::Embed::static_ext();

    @ExtUtils::Embed::Extensions = grep{$_} @ExtUtils::Embed::Extensions;

    #create bootstrap method for static xs modules
    my $static_xs = [keys %{ $build->{XS} }];
    ExtUtils::Embed::xsinit($xsinit, 1, $static_xs);

    #$self->generate_constants_pod();
}

my $constant_prefixes = join '|', qw{APR? MODPERL_RC};

sub generate_constants {
    my ($self, $h_fh, $c_fh) = @_;

    require Apache2::ConstantsTable;

    print $c_fh qq{\#include "modperl_const.h"\n};
    print $h_fh "#define MP_ENOCONST -3\n\n";

    generate_constants_lookup($h_fh, $c_fh);
    generate_constants_group_lookup($h_fh, $c_fh);
}

my %shortcuts = (
     NOT_FOUND => 'HTTP_NOT_FOUND',
     FORBIDDEN => 'HTTP_FORBIDDEN',
     AUTH_REQUIRED => 'HTTP_UNAUTHORIZED',
     SERVER_ERROR => 'HTTP_INTERNAL_SERVER_ERROR',
     REDIRECT => 'HTTP_MOVED_TEMPORARILY',
);

#backwards compat with older httpd/apr
#XXX: remove once we require newer httpd/apr
my %ifdef = map { $_, 1 }
    qw(APLOG_TOCLIENT APR_LIMIT_NOFILE), # added in ???
    qw(AP_MPMQ_STARTING AP_MPMQ_RUNNING AP_MPMQ_STOPPING
       AP_MPMQ_MPM_STATE), # added in 2.0.49
    qw(APR_FPROT_USETID APR_FPROT_GSETID
       APR_FPROT_WSTICKY APR_FOPEN_LARGEFILE), # added in 2.0.50?
    qw(OPT_INCNOEXEC OPT_INC_WITH_EXEC); # added/removed in 2.4

sub constants_ifdef {
    my $name = shift;

    if ($ifdef{$name}) {
        return ("#ifdef $name\n", "#endif /* $name */\n");
    }

    ("", "");
}

sub constants_lookup_code {
    my ($h_fh, $c_fh, $constants, $class) = @_;

    my (%switch, %alias);

    %alias = %shortcuts;

    my $postfix = canon_lc(lc $class);
    my $package = $class . '::';
    my $package_len = length $package;
    my ($first_let) = $class =~ /^(\w)/;

    my $func = canon_func(qw(constants lookup), $postfix);
    my $proto = "SV \*$func(pTHX_ const char *name)";

    print $h_fh "$proto;\n";

    print $c_fh <<EOF;

$proto
{
    if (*name == '$first_let' && strnEQ(name, "$package", $package_len)) {
        name += $package_len;
    }

    switch (*name) {
EOF

    for (@$constants) {
        if (s/^($constant_prefixes)(_)?//o) {
            $alias{$_} = join $2 || "", $1, $_;
        }
        else {
            $alias{$_} ||= $_;
        }
        next unless /^([A-Z])/;
        push @{ $switch{$1} }, $_;
    }

    for my $key (sort keys %switch) {
        my $names = $switch{$key};
        print $c_fh "      case '$key':\n";

        for my $name (@$names) {
            my @ifdef = constants_ifdef($alias{$name});
            print $c_fh <<EOF;
$ifdef[0]
          if (strEQ(name, "$name")) {
EOF

            if ($name eq 'DECLINE_CMD' ||
                $name eq 'DIR_MAGIC_TYPE' ||
                $name eq 'CRLF' ||
                $name eq 'AUTHN_PROVIDER_GROUP' ||
                $name eq 'AUTHZ_PROVIDER_GROUP' ||
                $name eq 'AUTHN_PROVIDER_VERSION' ||
                $name eq 'AUTHZ_PROVIDER_VERSION' ||
                $name eq 'AUTHN_DEFAULT_PROVIDER' ||
                $name eq 'AUTHN_PROVIDER_NAME_NOTE' ||
                $name eq 'AUTHZ_PROVIDER_NAME_NOTE' ||
                $name eq 'AUTHN_PREFIX' ||
                $name eq 'AUTHZ_PREFIX' ||
                $name eq 'CRLF_ASCII') {
                print $c_fh <<EOF;
              return newSVpv($alias{$name}, 0);
EOF
            }
            else {
                print $c_fh <<EOF;
              return newSViv($alias{$name});
EOF
            }

            print $c_fh <<EOF;
          }
$ifdef[1]
EOF
        }
        print $c_fh "      break;\n";
    }

    print $c_fh <<EOF
    };
    Perl_croak(aTHX_ "unknown $class\:: constant %s", name);
    return newSViv(MP_ENOCONST);
}
EOF
}

sub generate_constants_lookup {
    my ($h_fh, $c_fh) = @_;

    while (my ($class, $groups) = each %$Apache2::ConstantsTable) {
        my $constants = [map { @$_ } values %$groups];

        constants_lookup_code($h_fh, $c_fh, $constants, $class);
    }
}

sub generate_constants_group_lookup {
    my ($h_fh, $c_fh) = @_;

    while (my ($class, $groups) = each %$Apache2::ConstantsTable) {
        constants_group_lookup_code($h_fh, $c_fh, $class, $groups);
    }
}

sub constants_group_lookup_code {
    my ($h_fh, $c_fh, $class, $groups) = @_;
    my @tags;
    my @code;

    $class = canon_lc(lc $class);
    while (my ($group, $constants) = each %$groups) {
        push @tags, $group;
        my $name = join '_', 'MP_constants', $class, $group;
        print $c_fh "\nstatic const char *$name [] = { \n",
          (map {
              my @ifdef = constants_ifdef($_);
              s/^($constant_prefixes)_?//o;
              qq($ifdef[0]   "$_",\n$ifdef[1])
          } @$constants), "   NULL,\n};\n";
    }

    my %switch;
    for (@tags) {
        next unless /^([A-Z])/i;
        push @{ $switch{$1} }, $_;
    }

    my $func = canon_func(qw(constants group lookup), $class);

    my $proto = "const char **$func(const char *name)";

    print $h_fh "$proto;\n";
    print $c_fh "\n$proto\n{\n", "   switch (*name) {\n";

    for my $key (sort keys %switch) {
        my $val = $switch{$key};
        print $c_fh "\tcase '$key':\n";
        for my $group (@$val) {
            my $name = join '_', 'MP_constants', $class, $group;
            print $c_fh qq|\tif(strEQ("$group", name))\n\t   return $name;\n|;
        }
        print $c_fh "      break;\n";
    }

    print $c_fh <<EOF;
    };
    Perl_croak_nocontext("unknown $class\:: group `%s'", name);
    return NULL;
}
EOF
}

my %seen_const = ();
# generates APR::Const and Apache2::Const manpages in ./tmp/
sub generate_constants_pod {
    my ($self) = @_;

    my %data = ();
    generate_constants_group_lookup_doc(\%data);
    generate_constants_lookup_doc(\%data);

    # XXX: may be dump %data into ModPerl::MethodLookup and provide an
    # easy api to map const groups to constants and vice versa

    require File::Path;
    my $file = "Const.pod";
    for my $class (keys %data) {
        my $path = catdir "tmp", $class;
        File::Path::mkpath($path, 0, 0755);
        my $filepath = catfile $path, $file;
        open my $fh, ">$filepath" or die "Can't open $filepath: $!\n";

        print $fh <<"EOF";
=head1 NAME

$class\::Const - Perl Interface for $class Constants

=head1 SYNOPSIS

=head1 CONSTANTS

EOF

        my $groups = $data{$class};
        for my $group (sort keys %$groups) {
            print $fh <<"EOF";


=head2 C<:$group>

  use $class\::Const -compile qw(:$group);

The C<:$group> group is for XXX constants.

EOF

            for my $const (sort @{ $groups->{$group} }) {
                print $fh "=head3 C<$class\::$const>\n\n\n";
            }
        }

        print $fh "=cut\n";
    }
}

sub generate_constants_lookup_doc {
    my ($data) = @_;

    while (my ($class, $groups) = each %$Apache2::ConstantsTable) {
        my $constants = [map { @$_ } values %$groups];

        constants_lookup_code_doc($constants, $class, $data);
    }
}

sub generate_constants_group_lookup_doc {
    my ($data) = @_;

    while (my ($class, $groups) = each %$Apache2::ConstantsTable) {
        constants_group_lookup_code_doc($class, $groups, $data);
    }
}

sub constants_group_lookup_code_doc {
    my ($class, $groups, $data) = @_;
    my @tags;
    my @code;

    while (my ($group, $constants) = each %$groups) {
        $data->{$class}{$group} = [
            map {
                my @ifdef = constants_ifdef($_);
                s/^($constant_prefixes)_?//o;
                $seen_const{$class}{$_}++;
                $_;
            } @$constants
        ];
    }
}

sub constants_lookup_code_doc {
    my ($constants, $class, $data) = @_;

    my (%switch, %alias);

    %alias = %shortcuts;

    my $postfix = lc $class;
    my $package = $class . '::';
    my $package_len = length $package;

    my $func = canon_func(qw(constants lookup), $postfix);

    for (@$constants) {
        if (s/^($constant_prefixes)(_)?//o) {
            $alias{$_} = join $2 || "", $1, $_;
        }
        else {
            $alias{$_} ||= $_;
        }
        next unless /^([A-Z])/;
        push @{ $switch{$1} }, $_;
    }

    for my $key (sort keys %switch) {
        my $names = $switch{$key};
        for my $name (@$names) {
            my @ifdef = constants_ifdef($alias{$name});
            push @{ $data->{$class}{other} }, $name
                unless $seen_const{$class}{$name}
        }
    }
}

sub generate_exports {
    my ($self, $c_fh) = @_;
    require ModPerl::WrapXS;
    ModPerl::WrapXS->generate_exports($c_fh);
}

# src/modules/perl/*.c files needed to build APR/APR::* outside
# of mod_perl.so
sub src_apr_ext {
    return map { "modperl_$_" } (qw(error bucket),
                                  map { "common_$_" } qw(util log));
}

1;
__END__

=head1 NAME

ModPerl::Code - Generate mod_perl glue code

=head1 SYNOPSIS

  use ModPerl::Code ();
  my $code = ModPerl::Code->new;
  $code->generate;

=head1 DESCRIPTION

This module provides functionality for generating mod_perl glue code.
Reason this code is generated rather than written by hand include:

=over 4

=item consistency

=item thin and clean glue code

=item enable/disable features (without #ifdefs)

=item adapt to changes in Apache

=item experiment with different approaches to gluing

=back

=head1 AUTHOR

Doug MacEachern

=cut