# 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 Apache2::ParseSource;
use strict;
use warnings FATAL => 'all';
use Apache2::Build ();
use Config;
use File::Basename;
use File::Spec::Functions qw(catdir);
our $VERSION = '0.02';
sub new {
my $class = shift;
my $self = bless {
config => Apache2::Build->build_config,
@_,
}, $class;
my $prefixes = join '|', @{ $self->{prefixes} || [qw(ap_ apr_)] };
$self->{prefix_re} = qr{^($prefixes)};
$Apache2::Build::APXS ||= $self->{apxs};
$self;
}
sub config {
shift->{config};
}
sub parse {
my $self = shift;
$self->{scan_filename} = $self->generate_cscan_file;
$self->{c} = $self->scan;
}
sub DESTROY {
my $self = shift;
unlink $self->{scan_filename}
}
{
package Apache2::ParseSource::Scan;
our @ISA = qw(ModPerl::CScan);
sub get {
local $SIG{__DIE__} = \&Carp::confess;
shift->SUPER::get(@_);
}
}
my @c_scan_defines = (
'CORE_PRIVATE', #so we get all of apache
'MP_SOURCE_SCAN', #so we can avoid some c-scan barfing
'_NETINET_TCP_H', #c-scan chokes on netinet/tcp.h
'_BYTESWAP_H', #c-scan chokes on byteswap.h
'_BITS_BYTESWAP_H', #c-scan chokes on byteswap.h
'Expat_INCLUDED', #c-scan chokes on expath.h
# 'APR_OPTIONAL_H', #c-scan chokes on apr_optional.h
'apr_table_do_callback_fn_t=void', #c-scan chokes on function pointers
);
# some types c-scan failing to resolve
push @c_scan_defines, map { "$_=void" }
qw(PPADDR_t PerlExitListEntry modperl_tipool_vtbl_t);
sub scan {
require ModPerl::CScan;
ModPerl::CScan->VERSION(0.75);
require Carp;
my $self = shift;
my $c = ModPerl::CScan->new(filename => $self->{scan_filename});
my $includes = $self->includes;
# where to find perl headers, but we don't want to parse them otherwise
my $perl_core_path = catdir $Config{installarchlib}, "CORE";
push @$includes, $perl_core_path;
$c->set(includeDirs => $includes);
my @defines = @c_scan_defines;
unless ($Config{useithreads} and $Config{useithreads} eq 'define') {
#fake -DITHREADS so function tables are the same for
#vanilla and ithread perls, that is,
#make sure THX and friends are always expanded
push @defines, 'MP_SOURCE_SCAN_NEED_ITHREADS';
}
$c->set(Defines => join ' ', map "-D$_", @defines);
bless $c, 'Apache2::ParseSource::Scan';
}
sub include_dirs {
my $self = shift;
my $inc = $self->config->apxs('-q' => 'INCLUDEDIR');
my @dirs = ($inc, $self->config->mp_include_dir);
my $aprinc = $self->config->apxs('-q' => 'APR_INCLUDEDIR');
unless ($aprinc eq $inc) {
# Add APR include directory if different to httpd includedir
push @dirs, $aprinc;
}
@dirs;
}
sub includes { shift->config->includes }
sub find_includes {
my $self = shift;
return $self->{includes} if $self->{includes};
require File::Find;
my @includes = ();
# don't pick preinstalled mod_perl headers if any, but pick the rest
{
my @dirs = $self->include_dirs;
die "could not find include directory (build the project first)"
unless -d $dirs[0];
my $unwanted = join '|', qw(ap_listen internal version
apr_optional mod_include mod_cgi
mod_proxy mod_ssl ssl_ apr_anylock
apr_rmm ap_config mod_log_config
mod_perl modperl_ apreq mod_cache
mod_serf mod_dav);
$unwanted = qr|^$unwanted|;
my $wanted = '';
push @includes, find_includes_wanted($wanted, $unwanted, @dirs);
}
# now add the live mod_perl headers (to make sure that we always
# work against the latest source)
{
my @dirs = map { catdir $self->config->{cwd}, $_ }
catdir(qw(src modules perl)), 'xs';
my $unwanted = '';
my $wanted = join '|', qw(mod_perl modperl_);
$wanted = qr|^$wanted|;
push @includes, find_includes_wanted($wanted, $unwanted, @dirs);
}
# now reorg the header files list, so the fragile scan won't choke
my @apr = ();
my @mp = ();
my @rest = ();
for (@includes) {
if (/mod_perl.h$/) {
# mod_perl.h needs to be included before other mod_perl
# headers
unshift @mp, $_;
}
elsif (/modperl_\w+.h$/) {
push @mp, $_;
}
elsif (/apr_\w+\.h$/ ) {
# apr headers need to be included first
push @apr, $_;
}
else {
push @rest, $_;
}
}
@includes = (@apr, @rest, @mp);
return $self->{includes} = \@includes;
}
sub find_includes_wanted {
my ($wanted, $unwanted, @dirs) = @_;
my @includes = ();
for my $dir (@dirs) {
File::Find::finddepth({
wanted => sub {
return unless /\.h$/;
if ($wanted) {
return unless /$wanted/;
}
else {
return if /$unwanted/;
}
my $dir = $File::Find::dir;
push @includes, "$dir/$_";
},
(Apache2::Build::WIN32 ? '' : follow => 1),
}, $dir);
}
return @includes;
}
sub generate_cscan_file {
my $self = shift;
my $includes = $self->find_includes;
my $filename = '.apache_includes';
open my $fh, '>', $filename or die "can't open $filename: $!";
for my $path (@$includes) {
my $filename = basename $path;
print $fh qq(\#include "$path"\n);
}
close $fh;
return $filename;
}
my %defines_wanted = (
'Apache2::Const' => {
common => [qw{OK DECLINED DONE}],
config => [qw{DECLINE_CMD}],
context => [qw(NOT_IN_ GLOBAL_ONLY)],
http => [qw{HTTP_}],
log => [qw(APLOG_)],
methods => [qw{M_ METHODS}],
mpmq => [qw{AP_MPMQ_}],
options => [qw{OPT_}],
override => [qw{OR_ EXEC_ON_READ ACCESS_CONF RSRC_CONF}],
proxy => [qw{PROXYREQ_}],
platform => [qw{CRLF CR LF}],
remotehost => [qw{REMOTE_}],
satisfy => [qw{SATISFY_}],
types => [qw{DIR_MAGIC_TYPE}],
auth => [qw{AUTHN_ AUTHZ AP_AUTH_ AUTH_ AUTHZ_}],
},
'APR::Const' => {
common => [qw{APR_SUCCESS}],
error => [qw{APR_E}],
filepath => [qw{APR_FILEPATH_}],
filetype => [qw{APR_FILETYPE_}],
fopen => [qw{APR_FOPEN_}],
fprot => [qw{APR_FPROT_}],
finfo => [qw{APR_FINFO_}],
flock => [qw{APR_FLOCK_}],
hook => [qw{APR_HOOK_}],
limit => [qw{APR_LIMIT}],
poll => [qw{APR_POLL}],
socket => [qw{APR_SO_}],
status => [qw{APR_TIMEUP}],
table => [qw{APR_OVERLAP_TABLES_}],
uri => [qw{APR_URI_}],
},
ModPerl => {
common => [qw{MODPERL_RC_}],
}
);
my %defines_wanted_re;
while (my ($class, $groups) = each %defines_wanted) {
while (my ($group, $wanted) = each %$groups) {
my $pat = join '|', @$wanted;
$defines_wanted_re{$class}->{$group} = $pat; #qr{^($pat)};
}
}
my %enums_wanted = (
'Apache2::Const' => { map { $_, 1 } qw(cmd_how input_mode filter_type conn_keepalive authn_status authz_status) },
'APR::Const' => { map { $_, 1 } qw(apr_shutdown_how apr_read_type apr_lockmech) },
);
my $defines_unwanted = join '|', qw{
HTTP_VERSION APR_EOL_STR APLOG_MARK APLOG_NOERRNO APR_SO_TIMEOUT
APR_HOOK_PROBES_ENABLED APR_HOOK_INT_DCL_UD
APLOG_MAX_LOGLEVEL
APR_BEGIN_DECLS APR_END_DECLS
};
sub get_constants {
my ($self) = @_;
my $includes = $self->find_includes;
my (%constants, %seen);
for my $file (@$includes) {
open my $fh, $file or die "open $file: $!";
while (<$fh>) {
if (s/^\#define\s+(\w+)\s+.*/$1/) {
chomp;
next if /_H$/;
next if $seen{$_}++;
$self->handle_constant(\%constants);
}
elsif (m/enum[^\{]+\{/) {
$self->handle_enum($fh, \%constants);
}
}
close $fh;
}
#maintain a few handy shortcuts from 1.xx
#aliases are defined in ModPerl::Code
push @{ $constants{'Apache2::Const'}->{common} },
qw(NOT_FOUND FORBIDDEN AUTH_REQUIRED SERVER_ERROR REDIRECT);
return \%constants;
}
sub handle_constant {
my ($self, $constants) = @_;
my $keys = keys %defines_wanted_re;
return if /^($defines_unwanted)/o;
while (my ($class, $groups) = each %defines_wanted_re) {
my $keys = keys %$groups;
while (my ($group, $re) = each %$groups) {
next unless /^($re)/;
push @{ $constants->{$class}->{$group} }, $_;
return;
}
}
}
sub handle_enum {
my ($self, $fh, $constants) = @_;
my ($name, $e) = $self->parse_enum($fh);
return unless $name;
$name =~ s/^ap_//;
$name =~ s/_(e|t)$//;
my $class;
for (keys %enums_wanted) {
next unless $enums_wanted{$_}->{$name};
$class = $_;
}
return unless $class;
$name =~ s/^apr_//;
push @{ $constants->{$class}->{$name} }, @$e if $e;
}
#this should win an award for worlds lamest parser
sub parse_enum {
my ($self, $fh) = @_;
my $code = $_;
my @e;
unless ($code =~ /;\s*$/) {
local $_;
while (<$fh>) {
$code .= $_;
last if /;\s*$/;
}
}
my $name;
if ($code =~ s/^\s*enum\s+(\w*)\s*//) {
$name = $1;
}
elsif ($code =~ s/^\s*typedef\s+enum\s+//) {
$code =~ s/\s*(\w+)\s*;\s*$//;
$name = $1;
}
$code =~ s:/\*.*?\*/::sg;
$code =~ s/\s*=\s*\w+//g;
$code =~ s/^[^\{]*\{//s;
$code =~ s/\}[^;]*;?//s;
$code =~ s/^\s*\n//gm;
while ($code =~ /\b(\w+)\b,?/g) {
push @e, $1;
}
return ($name, \@e);
}
sub wanted_functions { shift->{prefix_re} }
sub wanted_structures { shift->{prefix_re} }
sub get_functions {
my $self = shift;
my $key = 'parsed_fdecls';
return $self->{$key} if $self->{$key};
my $c = $self->{c};
my $fdecls = $c->get($key);
my $inlines = $c->get('parsed_inlines');
push @{$fdecls}, @{$inlines};
my %seen;
my $wanted = $self->wanted_functions;
my @functions;
for my $entry (@$fdecls) {
my ($rtype, $name, $args) = @$entry;
next unless $name =~ $wanted;
next if $seen{$name}++;
my @attr;
for (qw(static __inline__)) {
if ($rtype =~ s/^($_)\s+//) {
push @attr, $1;
}
}
#XXX: working around ModPerl::CScan confusion here
#macro defines ap_run_error_log causes
#cpp filename:linenumber to be included as part of the type
for (@$args) {
next unless $_->[0];
$_->[0] =~ s/^\#.*?\"\s+//;
$_->[0] =~ s/^register //;
}
my $func = {
name => $name,
return_type => $rtype,
args => [map {
{ type => $_->[0], name => $_->[1] }
} @$args],
};
$func->{attr} = \@attr if @attr;
push @functions, $func;
}
# sort the functions by the 'name' attribute to ensure a
# consistent output on different systems.
$self->{$key} = [sort { $a->{name} cmp $b->{name} } @functions];
}
sub get_structs {
my $self = shift;
my $key = 'typedef_structs';
return $self->{$key} if $self->{$key};
my $c = $self->{c};
my $typedef_structs = $c->get($key);
my %seen;
my $wanted = $self->wanted_structures;
my $other = join '|', qw(_rec module
piped_log uri_t htaccess_result
cmd_parms cmd_func cmd_how);
my @structures;
my $sx = qr(^struct\s+);
while (my ($type, $elts) = each %$typedef_structs) {
next unless $type =~ $wanted or $type =~ /($other)$/o;
$type =~ s/$sx//;
next if $seen{$type}++;
my $struct = {
type => $type,
elts => [map {
my $type = $_->[0];
$type =~ s/$sx//;
$type .= $_->[1] if $_->[1];
$type =~ s/:\d+$//; #unsigned:1
{ type => $type, name => $_->[2] }
} @$elts],
};
push @structures, $struct;
}
# sort the structs by the 'type' attribute to ensure a consistent
# output on different systems.
$self->{$key} = [sort { $a->{type} cmp $b->{type} } @structures];
}
sub write_functions_pm {
my $self = shift;
my $file = shift || 'FunctionTable.pm';
my $name = shift || 'Apache2::FunctionTable';
$self->write_pm($file, $name, $self->get_functions);
}
sub write_structs_pm {
my $self = shift;
my $file = shift || 'StructureTable.pm';
my $name = shift || 'Apache2::StructureTable';
$self->write_pm($file, $name, $self->get_structs);
}
sub write_constants_pm {
my $self = shift;
my $file = shift || 'ConstantsTable.pm';
my $name = shift || 'Apache2::ConstantsTable';
$self->write_pm($file, $name, $self->get_constants);
}
sub write_pm {
my ($self, $file, $name, $data) = @_;
require Data::Dumper;
local $Data::Dumper::Indent = 1;
my ($subdir) = (split '::', $name)[0];
my $tdir = '';
my $build = Apache2::Build->new(init => 1);
my $httpd_version = $build->httpd_version;
if ($httpd_version lt '2.4.0') {
$tdir='xs/tables/current';
}
else {
$tdir='xs/tables/current24';
}
if (-d "$tdir/$subdir") {
$file = "$tdir/$subdir/$file";
}
# sort the hashes (including nested ones) for a consistent dump
canonsort(\$data);
my $dump = Data::Dumper->new([$data],
[$name])->Dump;
my $package = ref($self) || $self;
my $version = $self->VERSION;
my $date = scalar localtime;
my $new_content = << "EOF";
package $name;
# !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
# ! WARNING: generated by $package/$version
# ! $date
# ! do NOT edit, any changes will be lost !
# !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
$dump
1;
EOF
my $old_content = '';
if (-e $file) {
open my $pm, '<', $file or die "open $file: $!";
local $/ = undef; # slurp the file
$old_content = <$pm>;
close $pm;
}
my $overwrite = 1;
if ($old_content) {
# strip the date line, which will never be the same before
# comparing
my $table_header = qr{^\#\s!.*};
(my $old = $old_content) =~ s/$table_header//mg;
(my $new = $new_content) =~ s/$table_header//mg;
$overwrite = 0 if $old eq $new;
}
if ($overwrite) {
open my $pm, '>', $file or die "open $file: $!";
print $pm $new_content;
close $pm;
}
}
# canonsort(\$data);
# sort nested hashes in the data structure.
# the data structure itself gets modified
sub canonsort {
my $ref = shift;
my $type = ref $$ref;
return unless $type;
require Tie::IxHash;
my $data = $$ref;
if ($type eq 'ARRAY') {
for (@$data) {
canonsort(\$_);
}
}
elsif ($type eq 'HASH') {
for (keys %$data) {
canonsort(\$data->{$_});
}
tie my %ixhash, 'Tie::IxHash';
# reverse sort so we get the order of:
# return_type, name, args { type, name } for functions
# type, elts { type, name } for structures
for (sort { $b cmp $a } keys %$data) {
$ixhash{$_} = $data->{$_};
}
$$ref = \%ixhash;
}
}
1;
__END__