# 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 = sort(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";
foreach my $class (sort keys %{ $self->{handler_index_desc} }) {
my $h = $self->{handler_index_desc}->{$class};
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;
foreach my $class (sort keys %{ $self->{handlers} }) {
my $handlers = $self->{handlers}->{$class};
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;
foreach my $class (sort keys %{ $self->{hook_proto} }) {
my $prototype = $self->{hook_proto}->{$class};
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
foreach my $class (sort keys %{ $self->{handlers} }) {
my $handlers = $self->{handlers}->{$class};
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;
foreach my $class (sort keys %{ $self->{handlers} }) {
my $handlers = $self->{handlers}->{$class};
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";
foreach my $class (sort keys %{ $self->{flags} }) {
my $opts = $self->{flags}->{$class};
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 (sort 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 (sort 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 (sort 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 = [sort 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) = @_;
foreach my $class (sort keys %$Apache2::ConstantsTable) {
my $groups = $Apache2::ConstantsTable->{$class};
my $constants = [sort map { @$_ } values %$groups];
constants_lookup_code($h_fh, $c_fh, $constants, $class);
}
}
sub generate_constants_group_lookup {
my ($h_fh, $c_fh) = @_;
foreach my $class (sort keys %$Apache2::ConstantsTable) {
my $groups = $Apache2::ConstantsTable->{$class};
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);
foreach my $group (sort keys %$groups) {
my $constants = $groups->{$group};
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 (sort 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) = @_;
foreach my $class (sort keys %$Apache2::ConstantsTable) {
my $groups = $Apache2::ConstantsTable->{$class};
my $constants = [sort map { @$_ } values %$groups];
constants_lookup_code_doc($constants, $class, $data);
}
}
sub generate_constants_group_lookup_doc {
my ($data) = @_;
foreach my $class (sort keys %$Apache2::ConstantsTable) {
my $groups = $Apache2::ConstantsTable->{$class};
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