dougm 01/03/04 19:47:33
Added: lib/ModPerl WrapXS.pm
Log:
module to generating the Makefile.PL, .pm and .xs for a module
Revision Changes Path
1.1 modperl-2.0/lib/ModPerl/WrapXS.pm
Index: WrapXS.pm
===================================================================
package ModPerl::WrapXS;
use strict;
use warnings FATAL => 'all';
use Apache::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;
our $VERSION = '0.01';
my(@xs_includes) = ('mod_perl.h',
map "modperl_xs_$_.h", qw(util typedefs sv_convert));
sub new {
my $class = shift;
my $self = bless {
typemap => ModPerl::TypeMap->new,
includes => \@xs_includes,
glue_dirs => [xs_glue_dirs()],
}, $class;
for (qw(c hash)) {
my $w = "noedit_warning_$_";
my $method = "ModPerl::Code::$w";
$self->{$w} = $self->$method();
}
$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 (@{ $self->function_list() }) {
my $func;
next unless $func = $typemap->map_function($entry);
my($name, $module, $class, $args) =
@{ $func } { qw(perl_name module class args) };
#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/^$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 $code = <<EOF;
$return_type
$name($xs_parms)
$proto
EOF
if ($dispatch || $orig_args) {
my $thx = "";
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) {
$parms = 'items, MARK+1, SP';
}
my $retval = $return_type eq 'void' ?
["", ""] : ["RETVAL = ", "OUTPUT:\n RETVAL\n"];
$code .= <<EOF;
CODE:
$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 =~ s/^\./obj->/;
$val = "((ST(1) == &PL_sv_undef) ? NULL :
(SvPOK(ST(1)) ?
apr_pstrndup($pool, SvPVX(ST(1)), SvCUR(ST(1))) :
apr_pstrdup($pool, val)))";
}
}
return $val;
}
sub get_structures {
my $self = shift;
my $typemap = $self->typemap;
for my $entry (@$Apache::StructureTable) {
my $struct = $typemap->map_structure($entry);
next unless $struct;
my $class = $struct->{class};
for my $e (@{ $struct->{elts} }) {
my($name, $default, $type) =
@{$e}{qw(name default type)};
(my $cast = $type) =~ s/:/_/g;
my $val = get_value($e);
my $code = <<EOF;
$type
$name(obj, val=$default)
$class obj
$type val
CODE:
RETVAL = ($cast) obj->$name;
if (items > 1) {
obj->$name = ($cast) $val;
}
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} = join '/', fastcwd(), 'xs';
if (-e $self->{DIR}) {
rmtree([$self->{DIR}], 1, 1);
}
mkpath [$self->{DIR}], 1, 0755;
}
sub class_dirname {
my($self, $class) = @_;
my($base, $sub) = split '::', $class;
return "$self->{DIR}/$base" unless $sub; #Apache | 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}:) ?
join('/', $self->{DIR}, $dirname) : $dirname;
mkpath [$dir], 1, 0755 unless -d $dir;
$dir;
}
sub class_file {
my($self, $class, $file) = @_;
join '/', $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: $!";
print "writing...$name\n";
return $fh;
}
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;
print $fh <<EOF;
$self->{noedit_warning_hash}
use lib qw(../../lib); #for Apache::BuildConfig
use ModPerl::MM ();
ModPerl::MM::WriteMakefile(
'NAME' => '$class',
'VERSION' => '0.01',
'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 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);
$class_prefix . $name;
}
sub write_xs {
my($self, $module, $functions) = @_;
my $fh = $self->open_class_file($module, '.xs');
print $fh "$self->{noedit_warning_c}\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_Apache__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 "PROTOTYPES: disabled\n\n";
print $fh "BOOT:\n";
print $fh " items = items; /* -Wall */\n\n";
if (my $newxs = $self->{newXS}->{$module}) {
for my $xs (@$newxs) {
print $fh qq{ (void)newXS("$xs->[0]", $xs->[1], __FILE__);\n};
}
}
close $fh;
}
sub write_pm {
my($self, $module) = @_;
my $fh = $self->open_class_file($module, '.pm');
print $fh <<EOF;
$self->{noedit_warning_hash}
package $module;
use XSLoader ();
XSLoader::load __PACKAGE__;
1;
__END__
EOF
}
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->{noedit_warning_hash}\n";
while (my($type, $class) = each %$map) {
$class ||= $type;
next if $seen{$type}++ || $typemap->special($class);
if ($class =~ /::/) {
print $fh "$class\tT_PTROBJ\n";
}
else {
print $fh "$type\tT_$class\n";
}
}
close $fh;
}
sub write_typemap_h_file {
my($self, $method) = @_;
$method = $method . '_code';
my($h, $code) = $self->typemap->$method();
my $file = join '/', $self->{XS_DIR}, $h;
open my $fh, '>', $file or die "open $file: $!";
print $fh "$self->{noedit_warning_c}\n";
print $fh $code;
close $fh;
}
sub generate {
my $self = shift;
$self->prepare;
for (qw(ModPerl::WrapXS Apache APR)) {
$self->write_makefilepl($_);
}
$self->write_typemap;
for (qw(typedefs sv_convert)) {
$self->write_typemap_h_file($_);
}
$self->get_functions;
$self->get_structures;
while (my($module, $functions) = each %{ $self->{XS} }) {
# 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);
}
}
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;
}
1;
__END__
