| # 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__ |
