package ExtUtils::XSBuilder::WrapXS;
use strict;
use warnings FATAL => 'all';
use constant GvSHARED => 0; #$^V gt v5.7.0;
use File::Spec ;
use ExtUtils::XSBuilder::TypeMap ();
use ExtUtils::XSBuilder::MapUtil qw(function_table structure_table callback_table);
use ExtUtils::XSBuilder::PODTemplate ;
use File::Path qw(rmtree mkpath);
use Cwd qw(fastcwd);
use Data::Dumper;
use Carp qw(confess) ;
our $VERSION = '0.03';
my %warnings;
my $verbose = 0 ;
=pod
=head1 NAME
ExtUtils::XSBuilder::WrapXS - create perl XS wrappers for C functions
=head2 DESCRIPTION
For more information, see L<ExtUtils::XSBuilder>
=cut
# ============================================================================
sub new {
my $class = shift;
my $self = bless {
}, $class;
$self -> {glue_dirs} = [$self -> xs_glue_dirs()] ;
$self -> {typemap} = $self -> new_typemap ;
$self -> {parsesource} = $self -> new_parsesource ;
$self -> {xs_includes} = $self -> xs_includes ;
$self -> {callbackno} = 1 ;
for (qw(c hash)) {
my $w = "noedit_warning_$_";
my $method = $w ;
$self->{$w} = $self->$method();
}
$self->typemap->get;
$self;
}
# ============================================================================
sub classname {
my $self = shift || __PACKAGE__;
ref($self) || $self;
}
# ============================================================================
sub calls_trace {
my $frame = 1;
my $trace = '';
while (1) {
my($package, $filename, $line) = caller($frame);
last unless $filename;
$trace .= "$frame. $filename:$line\n";
$frame++;
}
return $trace;
}
# ============================================================================
sub noedit_warning_c {
my $class = classname(shift);
my $warning = \$warnings{C}->{$class};
return $$warning if $$warning;
my $v = join '/', $class, $class->VERSION;
my $trace = calls_trace();
$trace =~ s/^/ * /mg;
$$warning = <<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 = \$warnings{hash}->{$class};
return $$warning if $$warning;
($$warning = noedit_warning_c($class)) =~ s/^/\# /mg;
$$warning;
}
# ============================================================================
=pod
=head2 new_parsesource (o)
Returns an array ref of new ParseSource objects for all source files that
should be used to generate XS files
=cut
sub new_parsesource { [ ExtUtils::XSBuilder::ParseSource->new ] }
# ============================================================================
=pod
=head2 new_typemap (o)
Returns a new typemap object
=cut
sub new_typemap { ExtUtils::XSBuilder::TypeMap->new (shift) }
# ============================================================================
=pod
=head2 new_podtemplate (o)
Returns a new podtemplate object
=cut
sub new_podtemplate { ExtUtils::XSBuilder::PODTemplate->new }
# ============================================================================
=pod
=head2 xs_includes (o)
Returns a list of XS include files.
Default: use all include files that C<ParseSource::find_includes> returns, but
strip path info
=cut
sub xs_includes
{
my $self = shift ;
my $parsesource = $self -> parsesource_objects ;
my @includes ;
my @paths ;
foreach my $src (@$parsesource) {
push @includes, @{ $src -> find_includes } ;
push @paths, @{ $src -> include_paths } ;
}
foreach (@paths)
{
s#(\\|/)$## ;
s#\\#/# ;
}
foreach (@includes)
{
s#\\#/# ;
}
# strip include paths
foreach my $file (@includes)
{
foreach my $path (@paths)
{
if ($file =~ /^\Q$path\E(\/|\\)(.*?)$/i)
{
$file = $2 ;
last ;
}
}
}
my %includes = map { $_ => 1 } @includes ;
my $fixup1 = $self -> h_filename_prefix . 'preperl.h' ;
my $fixup2 = $self -> h_filename_prefix . 'postperl.h' ;
return [
keys %includes,
-f $self -> xs_include_dir . '/'. $fixup1?$fixup1:(),
'EXTERN.h', 'perl.h', 'XSUB.h',
-f $self -> xs_include_dir . '/'. $fixup2?$fixup2:(),
$self -> h_filename_prefix . 'sv_convert.h',
$self -> h_filename_prefix . 'typedefs.h',
] ;
}
# ============================================================================
=pod
=head2 xs_glue_dirs (o)
Returns a list of additional XS glue directories to seach for maps in.
=cut
sub xs_glue_dirs {
() ;
}
# ============================================================================
=pod
=head2 xs_base_dir (o)
Returns a directory which serves as a base for other directories.
Default: C<'.'>
=cut
sub xs_base_dir { '.' } ;
# ============================================================================
=pod
=head2 xs_map_dir (o)
Returns the directory to search for map files in
Default: C<<xs_base_dir>/xsbuilder/maps>
=cut
sub xs_map_dir { File::Spec -> catdir ($_[0] -> xs_base_dir, 'xsbuilder', 'maps') } ;
# ============================================================================
=pod
=head2 xs_incsrc_dir (o)
Returns the directory to search for files to include into the source. For
example, C<<xs_incsrc_dir>/Apache/DAV/Resource/Resource_pm> will be included into
the C<Apache::DAV::Resource> module.
Default: C<<xs_base_dir>/xsbuilder>
=cut
sub xs_incsrc_dir { File::Spec -> catdir ($_[0] -> xs_base_dir, 'xsbuilder') ; } ;
# ============================================================================
=pod
=head2 xs_include_dir (o)
Returns a directory to search for include files for pm and XS
Default: C<<xs_base_dir>/xsinclude>
=cut
sub xs_include_dir { File::Spec -> catdir ($_[0] -> xs_base_dir, 'xsinclude') ; } ;
# ============================================================================
=pod
=head2 xs_target_dir (o)
Returns the directory to write generated XS and header files in
Default: C<<xs_base_dir>/xs>
=cut
sub xs_target_dir { File::Spec -> catdir ($_[0] -> xs_base_dir, 'xs') ; }
# ============================================================================
sub typemap { shift->{typemap} }
# ============================================================================
sub includes { shift->{xs_includes} || [] }
# ============================================================================
sub parsesource_objects { shift->{parsesource} }
# ============================================================================
sub function_list {
my $self = shift;
my(@list) = @{ function_table($self) };
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 callback_list {
my $self = shift;
my(@list) = @{ callback_table($self) };
while (my($name, $val) = each %{ $self->typemap->callback_map }) {
#entries that do not exist in C::Scan generated tables
next unless $name =~ /^DEFINE_/;
push @list, $val;
}
return \@list;
}
# ============================================================================
sub get_callback_function {
my ($self, $func, $struct, $elt) = @_ ;
my $myprefix = $self -> my_xs_prefix ;
my $n ;
$elt -> {callbackno} = $n = $self -> {callbackno}++ ;
my $structelt = $elt -> {name} ;
my $class = $struct -> {class} ;
my $cclass = $self -> cname($class) ;
my($name, $args, $retargs, $return_type, $orig_args, $userdataarg) =
@{ $func } { qw(perl_name args retargs return_type orig_args userdataarg) };
$struct -> {staticcnt} ||= 4 ;
my $staticcnt = $struct -> {staticcnt} ;
#print "get_callback_function: ", Data::Dumper -> Dump([$func]), "\n" ;
my $code = "\n/* --- $class -> $structelt --- */\n\n" ;
my $cbname = "${myprefix}cb_${cclass}__$structelt" ;
my %retargs = map { $_->{name} => $_ } @$retargs ;
my %args = map { $_->{name} => $_ } @$args ;
my @args = map { my $name = /^(?:\*|&)(.*?)$/?$1:$_ ; ($args{$name}{rtype} || $retargs{$name}{rtype}) . (/^&/?" * $name":" $name") } @$orig_args ;
$return_type = $self -> cname($return_type) ;
my $return_class = $self -> typemap -> map_class ($return_type) || $return_type;
if ($return_class =~ / /)
{
print "ERROR: return class '$return_class' contains spaces" ;
}
my $desttype = 'CV' ;
if ($structelt)
{
$desttype = 'SV' ;
}
my $numret = $return_type eq 'void'?0:1 ;
$numret += @$retargs ;
my $callflags = $numret == 0?'G_VOID':$numret == 1?'G_SCALAR':'G_ARRAY' ;
$code .= qq[
static $return_type $cbname (] . join (',', "$desttype * __cbdest", @args) . qq[)
{
] ;
$code .= " $return_type __retval ;\n" if ($return_type && $return_type ne 'void') ;
$code .= " SV * __retsv ;\n" if ($numret) ;
$code .= qq[
int __cnt ;
dSP ;
ENTER ;
SAVETMPS ;
PUSHMARK(SP) ;
];
if ($structelt)
{
$code .= " PUSHs(__cbdest) ;\n" ;
}
foreach (@$orig_args) {
my $type = /^(?:\*|\&)(.*?)$/?$1:$_ ;
my $name = /^\*(.*?)$/?"&$1":$_ ;
next if ($retargs{$type}{class}) ;
if (!$args{$type}{class} && !$args{$type}{type})
{
print "WARNING: unknown type for argument '$name' in struct member '$structelt'\n" ;
print Dumper ($args) ;
next ;
}
my $class = $args{$type}{class} || $args{$type}{type} ;
if ($class =~/\s/)
{
print "WARNING: type '$class' for argument '$name' in struct member '$structelt' contains spaces\n" ;
print Dumper ($args) ;
next ;
}
$code .= ' PUSHs(' . $self -> convert_2obj ($class, $name) . ") ;\n" ;
}
$code .= qq[
PUTBACK ;
] ;
if ($structelt)
{
$code .= " __cnt = perl_call_method(\"cb_$structelt\", $callflags) ;\n" ;
}
else
{
$code .= " __cnt = perl_call_sv(__cbdest, $callflags) ;\n" ;
}
$code .= qq[
if (__cnt != $numret)
croak (\"$cbname expected $numret return values\") ;
] if ($numret > 0) ;
$code .= qq[
SPAGAIN ;
] ;
if ($return_type && $return_type ne 'void')
{
$code .= " __retsv = POPs;\n" ;
$code .= ' __retval = ' . $self -> convert_sv2 ($return_type, $return_class, '__retsv') . ";\n"
}
foreach (@$retargs) {
$code .= " __retsv = POPs;\n" ;
$code .= " *$_->{name} = " . $self -> convert_sv2 ($_->{rtype}, $_->{class}, '__retsv') . ";\n" ;
}
$code .= qq[
PUTBACK ;
FREETMPS ;
LEAVE ;
] ;
$code .= " return __retval ;\n" if ($return_type && $return_type ne 'void') ;
$code .= qq[
}
] ;
if (!$userdataarg) {
$staticcnt ||= 4 ;
for (my $i = 0 ; $i < $staticcnt; $i++) {
$code .= qq[
static $return_type ${cbname}_obj$i (] . join (',', @args) . qq[)
{
] . ($return_type eq 'void'?'':'return') . qq[ ${cbname} (] .
join (',', "${myprefix}${cclass}_obj[$i]", map { /^(?:\*|\&)?(.*?)$/ } @$orig_args) . qq[) ;
}
] ;
}
$code .= "typedef $return_type (*t${cbname}_func)(" . join (',', @args) . qq") ;\n" ;
$code .= "static t${cbname}_func ${myprefix}${cbname}_func [$staticcnt] = {\n " .
join (",\n ", map { "${cbname}_obj$_" } (0..$staticcnt-1)) . "\n } ;\n\n\n" ;
}
unshift @{ $self->{XS}->{ $func->{module} } }, {
code => $code,
class => '',
name => $name,
};
}
# ============================================================================
sub get_function {
my ($self, $func) = @_ ;
my $myprefix = $self -> my_xs_prefix ;
my($name, $module, $class, $args, $retargs) =
@{ $func } { qw(perl_name module class args retargs) };
my %retargs = map { $_->{name} => $_ } @$retargs ;
print "get_function: ", Data::Dumper -> Dump([$func]), "\n" if ($verbose);
#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 ;
if ($func -> {dispatch_argspec})
{
$parms = $func -> {dispatch_argspec} ;
}
else
{
($parms = join (',', $xs_parms,
map { "\&$_->{name}" } @$retargs)) =~
s/=[^,]+//g; #strip defaults
}
my $proto = join "\n",
(map " $_->{type} $_->{name}", @$args) ;
my $return_type =
$name =~ /^DESTROY$/ ? 'void' : $func->{return_type};
my $retdecl = @$retargs?(join "\n",
(map { my $type = $self -> cname($_->{class}) ; $type =~ s/\*$//; ' ' . $type . " $_->{name};"} @$retargs),
#' ' . $self -> cname($return_type) . ' RETVAL',
''):'';
my($dispatch, $orig_args) =
@{ $func } {qw(dispatch orig_args)};
if ($dispatch =~ /^$myprefix/io) {
$name =~ s/^$myprefix//;
$name =~ s/^$func->{prefix}//;
push @{ $self->{newXS}->{ $module } },
["$class\::$name", $dispatch];
return;
}
my $passthru = @$args && $args->[0]->{name} eq '...';
if ($passthru) {
$parms = '...';
$proto = '';
}
my $attrs = $self->attrs($name);
my $code = <<EOF;
$return_type
$name($xs_parms)
EOF
$code .= "$proto\n" if ($proto) ;
$code .= "$attrs\n" if ($attrs) ;
$code .= "PREINIT:\n$retdecl" if ($retdecl) ;
if ($dispatch || $orig_args) {
my $thx = "";
if ($dispatch) {
$thx = 'aTHX_ ' if $dispatch =~ /^$myprefix/i;
if ($orig_args && !$func -> {dispatch_argspec}) {
$parms = join ', ', map { $retargs{$_}?"&$_":$_} @$orig_args;
}
}
else {
### ??? gr ### if ($orig_args and @$orig_args == @$args) {
if ($orig_args && @$orig_args) {
#args were reordered
$parms = join ', ', map { $retargs{$_}?"&$_":$_} @$orig_args;
}
$dispatch = $func->{name};
}
if ($passthru) {
$thx ||= 'aTHX_ ';
$parms = 'items, MARK+1, SP';
}
my $retval = $return_type eq 'void' ?
["", ""] : ["RETVAL = ", "OUTPUT:\n RETVAL\n"];
my $retnum = $retdecl?scalar(@$retargs) + ($return_type eq 'void' ?0:1):0 ;
$code .= $retdecl?"PPCODE:":"CODE:" ;
$code .= "\n $retval->[0]$dispatch($thx$parms);\n" ;
if ($retdecl) {
my $retclass = $self -> typemap -> map_class ($return_type) || $return_type ;
if ($retclass =~ / /)
{
print "ERROR: return class '$retclass' contains spaces" ;
}
$code .= " XSprePUSH;\n" ;
$code .= " EXTEND(SP, $retnum) ;\n" ;
$code .= ' PUSHs(' . $self -> convert_2obj ($retclass, 'RETVAL') . ") ;\n" ;
foreach (@$retargs) {
if ($_->{class} =~ / /)
{
print "ERROR: $_->{class} contains spaces; retargs = ", Dumper ($_) ;
}
$code .= ' PUSHs(' . $self -> convert_2obj ($_->{class}, $_->{name}) . ") ;\n" ;
}
}
else {
$code .= "$retval->[1]\n" ;
}
}
$code .= "\n" ;
$func->{code} = $code;
push @{ $self->{XS}->{ $module } }, $func;
}
# ============================================================================
sub get_functions {
my $self = shift;
my $typemap = $self->typemap;
my %seen ;
for my $entry (@{ $self->function_list() }) {
#print "get_func ", Dumper ($entry) ;
my $func = $typemap->map_function($entry);
#print "FAILED to map $entry->{name}\n" unless $func;
next unless $func;
print "WARNING: Duplicate function: $entry->{name}\n" if ($seen{$entry->{name}}++) ;
$self -> get_function ($func) ;
}
}
# ============================================================================
sub get_value {
my $e = shift;
my $val = 'val';
if ($e->{class} eq 'PV') {
if (my $pool = $e->{pool}) {
$pool .= '(obj)';
$val = "((ST(1) == &PL_sv_undef) ? NULL :
apr_pstrndup($pool, val, val_len))"
}
}
return $val;
}
# ============================================================================
sub get_structure_callback_init {
my ($self, $class, $struct) = @_ ;
my $cclass = $self -> cname($class) ;
my $myprefix = $self -> my_xs_prefix ;
my $staticcnt = $struct -> {staticcnt} ;
my $cnv = $self -> convert_sv2 ($cclass, $class, 'obj') ;
my $code = qq[
void
init_callbacks (obj, val=NULL)
SV * obj
SV * val
PREINIT:
int n = -1 ;
int i ;
$cclass cobj = $cnv ;
SV * ref ;
SV * perl_obj ;
CODE:
if (items > 1)
obj = val ;
perl_obj = SvRV(obj) ;
ref = newRV_noinc(perl_obj) ;
for (i=0;i < $staticcnt;i++)
{
if ($myprefix${cclass}_obj[i] == ref)
{
n = i ;
break ;
}
}
if (n < 0)
for (i=0;i < $staticcnt;i++)
{
if ($myprefix${cclass}_obj[i] == NULL)
{
n = i ;
break ;
}
}
if (n < 0)
croak ("Limit for concurrent object callbacks reached for $class. Limit is $staticcnt") ;
$myprefix${cclass}_obj[n] = ref ;
] ;
foreach my $e (@{ $struct->{elts} }) {
if ($e -> {callback}) {
my $cbname = "${myprefix}cb_${cclass}__$e->{name}" ;
$code .= " cobj -> $e->{name} = ${myprefix}${cbname}_func[n] ;\n" ;
}
}
$code .= qq[
] ;
my $ccode = "static SV * ${myprefix}${cclass}_obj[$staticcnt] ;\n\n" ;
push @{ $self->{XS}->{ $struct->{module} } }, {
code => $code,
class => $class,
name => 'init_callbacks',
};
unshift @{ $self->{XS}->{ $struct->{module} } }, {
code => $ccode,
class => '',
name => 'init_callbacks',
};
}
# ============================================================================
sub get_structure_new {
my ($self, $class, $struct) = @_ ;
my $cclass = $self -> cname($class) ;
my $cnvprefix = $self -> my_cnv_prefix ;
my $alloc = $struct -> {alloc} || 'malloc(sizeof(*cobj))' ;
my $code = qq[
SV *
new (class,initializer=NULL)
char * class
SV * initializer
PREINIT:
SV * svobj ;
$cclass cobj ;
SV * tmpsv ;
CODE:
${cnvprefix}${cclass}_create_obj(cobj,svobj,RETVAL,$alloc) ;
if (initializer) {
if (!SvROK(initializer) || !(tmpsv = SvRV(initializer)))
croak ("initializer for ${class}::new is not a reference") ;
if (SvTYPE(tmpsv) == SVt_PVHV || SvTYPE(tmpsv) == SVt_PVMG)
${cclass}_new_init (aTHX_ cobj, tmpsv, 0) ;
else if (SvTYPE(tmpsv) == SVt_PVAV) {
int i ;
SvGROW(svobj, sizeof (*cobj) * av_len((AV *)tmpsv)) ;
for (i = 0; i <= av_len((AV *)tmpsv); i++) {
SV * * itemrv = av_fetch((AV *)tmpsv, i, 0) ;
SV * item ;
if (!itemrv || !*itemrv || !SvROK(*itemrv) || !(item = SvRV(*itemrv)))
croak ("array element of initializer for ${class}::new is not a reference") ;
${cclass}_new_init (aTHX_ &cobj[i], item, 1) ;
}
}
else {
croak ("initializer for ${class}::new is not a hash/array/object reference") ;
}
}
OUTPUT:
RETVAL
] ;
my $c_code = qq[
void ${cclass}_new_init (pTHX_ $cclass obj, SV * item, int overwrite) {
SV * * tmpsv ;
if (SvTYPE(item) == SVt_PVMG)
memcpy (obj, (void *)SvIVX(item), sizeof (*obj)) ;
else if (SvTYPE(item) == SVt_PVHV) {
] ;
foreach my $e (@{ $struct->{elts} }) {
if ($e -> {name} =~ /^(.*?)\[(.*?)\]$/) {
my $strncpy = $2 ;
my $name = $1 ;
my $perl_name ;
($perl_name = $e -> {perl_name}) =~ s/\[.*?\]$// ;
$c_code .= " if ((tmpsv = hv_fetch((HV *)item, \"$perl_name\", sizeof(\"$perl_name\") - 1, 0)) || overwrite) {\n" ;
$c_code .= " STRLEN l = 0;\n" ;
$c_code .= " if (tmpsv) {\n" ;
$c_code .= " char * s = SvPV(*tmpsv,l) ;\n" ;
$c_code .= " if (l > ($strncpy)-1) l = ($strncpy) - 1 ;\n" ;
$c_code .= " strncpy(obj->$name, s, l) ;\n" ;
$c_code .= " }\n" ;
$c_code .= " obj->$name\[l] = '\\0';\n" ;
$c_code .= " }\n" ;
} elsif (($e -> {class} !~ /::/) || ($e -> {rtype} =~ /\*$/)) {
$c_code .= " if ((tmpsv = hv_fetch((HV *)item, \"$e->{perl_name}\", sizeof(\"$e->{perl_name}\") - 1, 0)) || overwrite) {\n" ;
if ($e -> {malloc}) {
my $type = $e->{rtype} ;
my $dest = "obj -> $e->{name}" ;
my $src = 'tmpobj' ;
my $expr = eval ('"' . $e -> {malloc} . '"') ;
print $@ if ($@) ;
$c_code .= " $type tmpobj = (" . $self -> convert_sv2 ($e->{rtype}, $e->{class}, '(tmpsv && *tmpsv?*tmpsv:&PL_sv_undef)') . ");\n" ;
$c_code .= " if (tmpobj)\n" ;
$c_code .= " $expr;\n" ;
$c_code .= " else\n" ;
$c_code .= " $dest = NULL ;\n" ;
}
else {
$c_code .= ' ' . "obj -> $e->{name} = " . $self -> convert_sv2 ($e->{rtype}, $e->{class}, '(tmpsv && *tmpsv?*tmpsv:&PL_sv_undef)') . " ;\n" ;
}
$c_code .= " }\n" ;
}
}
$c_code .= qq[ ; }
else
croak ("initializer for ${class}::new is not a hash or object reference") ;
} ;
] ;
push @{ $self->{XS}->{ $struct->{module} } }, {
code => $code,
class => $class,
name => 'new',
};
unshift @{ $self->{XS}->{ $struct->{module} } }, {
code => $c_code,
class => '',
name => 'new',
};
}
# ============================================================================
sub get_structure_destroy {
my ($self, $class, $struct) = @_ ;
my $cclass = $self -> cname($class) ;
my $cnvprefix = $self -> my_cnv_prefix ;
my $code = qq[
void
DESTROY (obj)
$class obj
CODE:
${cclass}_destroy (aTHX_ obj) ;
] ;
my $numfree = 0 ;
my $c_code = qq[
void ${cclass}_destroy (pTHX_ $cclass obj) {
];
foreach my $e (@{ $struct->{elts} }) {
if (($e -> {class} !~ /::/) || ($e -> {rtype} =~ /\*$/)) {
if ($e -> {free}) {
my $src = "obj -> $e->{name}" ;
my $type = $e->{rtype} ;
my $expr = eval ('"' . $e -> {free} . '"') ;
print $@ if ($@) ;
$c_code .= " if (obj -> $e->{name})\n" ;
$c_code .= ' ' . $expr . ";\n" ;
$numfree++ ;
}
}
}
$c_code .= "\n};\n\n" ;
if ($numfree) {
push @{ $self->{XS}->{ $struct->{module} } }, {
code => $code,
class => $class,
name => 'destroy',
};
unshift @{ $self->{XS}->{ $struct->{module} } }, {
code => $c_code,
class => '',
name => 'destroy',
};
}
}
# ============================================================================
sub get_structures {
my $self = shift;
my $typemap = $self->typemap;
my $has_callbacks = 0 ;
for my $entry (@{ structure_table($self) }) {
print 'struct ', $entry->{type} || '???', "...\n" ;
my $struct = $typemap->map_structure($entry);
print Data::Dumper -> Dump ([$entry, $struct], ['Table Entry', 'Mapfile Entry']) if ($verbose) ;
if (!$struct)
{
print "WARNING: Struture '$entry->{type}' not found in map file\n" ;
next ;
}
my $class = $struct->{class};
$has_callbacks = 0 ;
for my $e (@{ $struct->{elts} }) {
my($name, $default, $type, $perl_name ) =
@{$e}{qw(name default type perl_name)};
print " $name...\n" ;
if ($e -> {callback}) {
#print "callback < ", Dumper ($e) , "\n" ;
$self -> get_function ($e -> {func}) ;
$self -> get_callback_function ($e -> {func}, $struct, $e) ;
$has_callbacks++ ;
}
else {
(my $cast = $type) =~ s/:/_/g;
my $val = get_value($e);
my $type_in = $type;
my $preinit = "/*nada*/";
my $address = '' ;
my $rdonly = 0 ;
my $strncpy ;
if ($e->{class} eq 'PV' and $val ne 'val') {
$type_in =~ s/char/char_len/;
$preinit = "STRLEN val_len;";
} elsif (($e->{class} =~ /::/) && ($e -> {rtype} !~ /\*\s*$/)) {
# an inlined struct is read only
$rdonly = 1 ;
$address = '&' ;
} elsif ($name =~ /^(.*?)\[(.*?)\]$/) {
$strncpy = $2 ;
$name = $1 ;
$perl_name =~ s/\[.*?\]$// ;
$type = 'char *' ;
$type_in = 'char *' ;
$cast = 'char *' ;
}
my $attrs = $self->attrs($name);
my $code = <<EOF;
$type
$perl_name(obj, val=$default)
$class obj
$type_in val
PREINIT:
$preinit
$attrs
CODE:
RETVAL = ($cast) $address obj->$name;
EOF
if ($rdonly) {
$code .= <<EOF
if (items > 1) {
croak (\"$name is read only\") ;
}
EOF
}
else {
$code .= "\n if (items > 1) {\n" ;
if ($e -> {malloc}) {
my $dest = "obj->$name" ;
my $src = $val ;
my $type = $cast ;
my $expr = eval ('"' . $e -> {malloc} . '"') ;
print $@ if ($@) ;
$code .= ' ' . $expr . ";\n" ;
}
elsif ($strncpy) {
$code .= " strncpy(obj->$name, ($cast) $val, ($strncpy) - 1) ;\n" ;
$code .= " obj->$name\[($strncpy)-1] = '\\0';\n" ;
}
else {
$code .= " obj->$name = ($cast) $val;\n" ;
}
$code .= " }\n" ;
}
$code .= <<EOF;
OUTPUT:
RETVAL
EOF
push @{ $self->{XS}->{ $struct->{module} } }, {
code => $code,
class => $class,
name => $name,
perl_name => $e -> {perl_name},
comment => $e -> {comment},
struct_member => $e,
};
}
}
$self -> get_structure_new($class, $struct) if ($struct->{has_new}) ;
$self -> get_structure_destroy($class, $struct) if ($struct->{has_new}) ;
$self -> get_structure_callback_init ($class, $struct) if ($has_callbacks);
}
}
# ============================================================================
sub prepare {
my $self = shift;
$self->{DIR} = $self -> xs_target_dir;
$self->{XS_DIR} = $self -> xs_target_dir ;
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";
$class =~ s/::/\//g ;
return $class ;
}
# ============================================================================
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;
my $dir = join('/', $self->{DIR}, $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) = @_;
confess ('ERROR: class is undefined in cname') if (!defined ($class)) ;
$class =~ s/::$// ;
$class =~ s/:/_/g;
$class;
}
# ============================================================================
sub convert_2obj {
my($self, $class, $name) = @_;
$self -> my_cnv_prefix . $self -> cname($class) . "_2obj($name)" ;
}
# ============================================================================
sub convert_sv2 {
my($self, $rtype, $class, $name) = @_;
$class =~ s/^const\s+// ;
$class =~ s/char\s*\*/PV/ ;
$class =~ s/SV\s*\*/SV/ ;
return "($rtype)" . $self -> my_cnv_prefix . 'sv2_' . $self -> cname($class) . "($name)" ;
}
# ============================================================================
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;
}
# ============================================================================
=pod
=head2 makefilepl_text (o)
Returns text for Makefile.PL
=cut
sub makefilepl_text {
my($self, $class, $deps,$typemap) = @_;
my @parts = split (/::/, $class) ;
my $mmargspath = '../' x @parts ;
$mmargspath .= 'mmargs.pl' ;
my $txt = qq{
$self->{noedit_warning_hash}
use ExtUtils::MakeMaker ();
local \$MMARGS ;
if (-f '$mmargspath')
{
do '$mmargspath' ;
die \$\@ if (\$\@) ;
}
\$MMARGS ||= {} ;
ExtUtils::MakeMaker::WriteMakefile(
'NAME' => '$class',
'VERSION' => '0.01',
'TYPEMAPS' => ['$typemap'],
} ;
$txt .= "'depend' => $deps,\n" if ($deps) ;
$txt .= qq{
\%\$MMARGS,
);
} ;
}
# ============================================================================
sub write_makefilepl {
my($self, $class) = @_;
$self -> {makefilepls}{$class} = 1 ;
my $fh = $self->open_class_file($class, 'Makefile.PL');
my $includes = $self->includes;
my @parts = split '::', $class ;
my $xs = @parts?$parts[-1] . '.c':'' ;
my $deps = {$xs => ""};
if (my $mod_h = $self->mod_h($class, 1)) {
my $abs = File::Spec -> rel2abs ($mod_h) ;
my $rel = File::Spec -> abs2rel ($abs, $self -> class_dir ($class)) ;
$deps->{$xs} .= " $rel";
}
local $Data::Dumper::Terse = 1;
$deps = Dumper $deps;
$deps = undef if (!$class) ;
$class ||= 'WrapXS' ;
print $fh $self -> makefilepl_text ($class, $deps, ('../' x @parts) . 'typemap') ;
close $fh;
}
# ============================================================================
sub write_missing_makefilepls {
my($self, $class) = @_;
my %classes = ('' => 1) ;
foreach (keys %{$self -> {makefilepls}})
{
my @parts = split (/::/, $_) ;
my $i ;
for ($i = 0; $i < @parts; $i++)
{
$classes{join('::', @parts[0..$i])} = 1 ;
}
}
foreach my $class (keys %classes)
{
next if ($self -> {makefilepls}{$class}) ;
$self -> write_makefilepl ($class) ;
}
}
# ============================================================================
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_include_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 @parts = split '::', $module;
my $mod_pm = "$dirname/$parts[-1]_pm";
for ($self -> xs_incsrc_dir, @{ $self->{glue_dirs} }) {
my $file = "$_/$mod_pm";
$mod_pm = $file if $complete;
print "mod_pm $mod_pm $file $complete\n" ;
return $mod_pm if -e $file;
}
undef;
}
# ============================================================================
=pod
=head2 h_filename_prefix (o)
Defines a prefix for generated header files
Default: C<'xs_'>
=cut
sub h_filename_prefix { 'xs_' }
# ============================================================================
=pod
=head2 my_xs_prefix (o)
Defines a prefix used for all XS functions
Default: C<'xs_'>
=cut
sub my_xs_prefix { 'xs_' }
# ============================================================================
=pod
=head2 my_cnv_prefix (o)
Defines a prefix used for all conversion functions/macros.
Default: C<my_xs_prefix>
=cut
sub my_cnv_prefix { $_[0] -> my_xs_prefix }
# ============================================================================
=pod
=head2 needs_prefix (o, name)
Returns true if the passed name should be prefixed
=cut
sub needs_prefix {
return 0 if (!$_[1]) ;
my $pf = $_[0] -> my_xs_prefix ;
return $_[1] !~ /^$pf/i;
}
# ============================================================================
sub isa_str {
my($self, $module) = @_;
my $str = "";
if (my $isa = $self->typemap->{function_map}->{isa}->{$module}) {
while (my($sub, $base) = each %$isa) {
#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 = ' ' . $self -> my_xs_prefix . $self->cname($module) . "_BOOT(aTHXo);\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: shared\n" if GvSHARED;
$str;
}
# ============================================================================
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 = "";
my $fmap = $self -> typemap -> {function_map} ;
my $myprefix = $self -> my_xs_prefix ;
for my $func (@$functions) {
my $class = $func->{class};
if ($class)
{
my $prefix = $func->{prefix};
$last_prefix = $prefix if $prefix;
if ($func->{name} =~ /^$myprefix/o) {
#e.g. mpxs_Apache__RequestRec_
my $class_prefix = $fmap -> class_c_prefix($class);
if ($func->{name} =~ /$class_prefix/) {
$prefix = $fmap -> class_xs_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 $self->boot($module);
print $fh " items = items; /* -Wall */\n\n";
if (my $newxs = $self->{newXS}->{$module}) {
for my $xs (@$newxs) {
print $fh qq{ cv = newXS("$xs->[0]", $xs->[1], __FILE__);\n};
print $fh qq{ GvSHARED_on(CvGV(cv));\n} if GvSHARED;
}
}
close $fh;
}
# ============================================================================
=pod
=head2 pm_text (o, module, isa, code)
Returns the text of a C<.pm> file, or undef if no C<.pm> file should be
written.
Default: Create a C<.pm> file which bootstraps the XS code
=cut
sub pm_text {
my($self, $module, $isa, $code) = @_;
return <<EOF;
$self->{noedit_warning_hash}
package $module;
require DynaLoader ;
use strict ;
use vars qw{\$VERSION \@ISA} ;
$isa
push \@ISA, 'DynaLoader' ;
\$VERSION = '0.01';
bootstrap $module \$VERSION ;
$code
1;
__END__
EOF
}
# ============================================================================
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];
my $loader = join '::', $base, 'XSLoader';
my $text = $self -> pm_text ($module, $isa, $code) ;
return if (!$text) ;
my $fh = $self->open_class_file($module, '.pm');
print $fh $text ;
}
# ============================================================================
sub write_typemap {
my $self = shift;
my $typemap = $self->typemap;
my $map = $typemap->get;
my %seen;
my $fh = $self->open_class_file('', 'typemap');
print $fh "$self->{noedit_warning_hash}\n";
while (my($type, $t) = each %$map) {
my $class = $t -> {class} ;
$class ||= $type;
next if $seen{$type}++ || $typemap->special($class);
my $typemap = $t -> {typemapid} ;
if ($class =~ /::/) {
next if $seen{$class}++ ;
$class =~ s/::$// ;
print $fh "$class\t$typemap\n";
}
else {
print $fh "$type\t$typemap\n";
}
}
my $cnvprefix = $self -> my_cnv_prefix ;
my $typemap_code = $typemap -> typemap_code ($cnvprefix);
foreach my $dir ('INPUT', 'OUTPUT') {
print $fh "\n$dir\n" ;
while (my($type, $code) = each %{$typemap_code}) {
print $fh "$type\n$code->{$dir}\n\n" if ($code->{$dir}) ;
}
}
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 _pod_gen_siglet {
my $class = shift || '' ;
return '\%' if $class eq 'HV';
return '\@' if $class eq 'AV';
return '$';
}
# ============================================================================
# Determine if the name is that of a function or an object
sub _pod_is_function {
my $class = shift || '';
#print "_pod_is_function($class)\n";
my %func_class = (
SV => 1,
IV => 1,
NV => 1,
PV => 1,
UV => 1,
PTR => 1,
);
exists $func_class{$class};
}
# ============================================================================
sub generate_pod {
my $self = shift ;
my $fh = shift;
my $pdd = shift;
my $templ = $self -> new_podtemplate ;
my $since = $templ -> since_default ;
print $fh $templ -> gen_pod_head ($pdd->{module}) ;
my $detail = $pdd->{functions_detailed};
unless ( ref($detail) eq 'ARRAY') {
warn "No functions listed in pdd structure for $pdd->{module}";
return;
}
foreach my $f (@$detail) {
# Generate the function or method name
my $method = $f->{perl_name};
$method = $1 if ($f->{prefix} && ($method =~ /^$f->{prefix}(.*?)$/)) ;
$method = $1 if ($f->{class_xs_prefix} && ($method =~ /^(?:DEFINE_)?$f->{class_xs_prefix}(.*?)$/)) ;
if (!$method) {
warn "Cannot determinate method name for '$f->{name}'" ;
next ;
}
my $comment = $f->{comment_parsed};
my $commenttext = ($comment->{func_desc} || '') . "\n\n" . ($comment->{doxygen_remark} || '') ;
my $member = $f -> {struct_member};
if ($member)
{
print $fh $templ -> gen_pod_struct_member ($f->{class}, '$obj', $f->{struct_member}->{class}, $f->{perl_name}, $commenttext, $since) ;
}
else
{
my $args = $f->{args};
if ($args && @$args)
{
my @param_nm = map { $_ -> {name} } @$args ; # Parameter names
my $obj_nm;
my $obj_sym;
my $offset = 0;
my $first_param = $f->{args}[0];
unless (_pod_is_function($first_param->{class})) {
$obj_nm = $param_nm[0]; # Object Name
$obj_sym = &_pod_gen_siglet($first_param->{class}). $obj_nm;
$offset++;
}
my $retclass ;
my $retcomment = $comment -> {doxygen_return} || '' ;
if ($f -> {return_type} && $f -> {return_type} ne 'void') {
my $rettype = $self -> typemap->get->{$f -> {return_type}} ;
$retclass = $rettype?$rettype->{class}:$f -> {return_type};
}
my @param;
my $i = 0 ;
for my $param_nm (@param_nm) {
my $arg = $args->[$i++];
push @param, { class => $arg->{class}, name => &_pod_gen_siglet($arg->{class}) . $param_nm,
comment => ($comment->{doxygen_param_desc}{$param_nm} || '') } ;
}
print $fh $templ -> gen_pod_func ($obj_sym, $obj_sym, $method, \@param, $retclass, $retcomment, $commenttext, $since) ;
}
}
}
}
# ============================================================================
# pdd = PERL Data Dumper
sub write_docs {
my($self, $module, $functions) = @_;
my $fh = $self->open_class_file($module, '.pdd');
print $fh "$self->{noedit_warning_hash}\n";
# Includes
my @includes = @{ $self->includes };
if (my $mod_h = $self->mod_h($module)) {
push @includes, $mod_h;
}
my $last_prefix = "";
my $fmap = $self->typemap->{function_map} ;
my $myprefix = $self->my_xs_prefix ;
# Finding doxygen- and other data inside the comments
# This code only knows the syntax for @ingroup, @param, @remark,
# @return and @warning. At the moment all other doxygen commands
# are treated as multiple-occurance, no-parameter commands.
# Note: Nor does @deffunc exist in the doxygen specification,
# neither does @remark (but @remarks), @tip and @see. So we treat
# @remark like @remarks, but we don't do any speacial treating for
# @deffunc. Ideas or suggestions anyone?
# --Axel Beckert
foreach my $details (@$functions) {
#print "Comment: ", $details->{name} || '?', ': ', $details->{comment} || '-', "\n" ;
#print "----> ", Dumper ($details) ;# if (!$details->{comment}) ;
if (defined $details->{comment} and
my $comment = $details->{comment}) {
$details->{comment_parsed} = {};
# Source file
if ($comment =~ s/^\s*(\S*\.c)\s+\*\n//s) {
$details->{comment_parsed}{source_file} = $1;
}
# Initialize several fields
$details->{comment_parsed}{func_desc} = "";
my $doxygen = 0; # flag indicating that we already have
# seen doxygen fields in this comment
my $type = 0; # name of doxygen field
my $pre = 0; # if we should recognize leading
# spaces. Example see apr_table_overlap
# Setting some regexps
my $ordinary_line = qr/^\s*?\*(\s*(.*?))\s*$/;
my $pre_begin = qr(<PRE>)i;
my $pre_end = qr(</PRE>)i;
# Parse the rest of the comment line by line, because
# doxygen fields can appear more than once
foreach my $line (split /\n/, $comment) {
# Yesss! This looks like doxygen data.
if ($line =~ /^\s*\*\s+[\\@](\w+)\s+(.*)\s*$/) {
$type = $doxygen = $1;
my $info = $2;
# setting the recognizing of leading spaces
$pre = ($info =~ $pre_begin ? 1 : $pre);
$pre = ($info =~ $pre_end ? 0 : $pre);
# Already had a doxygen element of this type for this func.
if (defined $details->{comment_parsed}{"doxygen_$type"}) {
push(@{ $details->{comment_parsed}{"doxygen_$type"} },
$info);
}
# Hey, hadn't seen this doxygen type in this function yet!
else {
$details->{comment_parsed}{"doxygen_$type"} = [ $info ];
}
}
# Further line belonging to doxygen field of the last line
elsif ($doxygen) {
# An empty line ends a doxygen paragraph
if ($line =~ /^\s*$/) {
$doxygen = 0;
next;
}
# Those two situations should never appear. But we
# better double check those things.
croak("There already was a doxygen comment, but it didn't set an type.\nStrange things happen")
unless defined $details->{comment_parsed}{"doxygen_$type"};
croak("This ($line) maybe an syntactic incorrect doxygen line.\nStrange things happen")
unless $line =~ $ordinary_line;
my $info = $2;
$info = $1 if $pre;
# setting the recognizing of leading spaces
$pre = ($info =~ $pre_begin ? 1 : $pre);
$pre = ($info =~ $pre_end ? 0 : $pre);
$info =~ s(^\s+</PRE>)(</PRE>)i;
# Ok, get me the last line of documentation.
my $lastline =
pop @{ $details->{comment_parsed}{"doxygen_$type"} };
# Concatenate that line and the actual line with a newline
$info = "$lastline\n$info";
# Strip empty lines at the end and beginning
# unless there was a <PRE> before.
unless ($pre) {
$info =~ s/[\n\s]+$//s;
$info =~ s/^[\n\s]+//s;
}
# Push the back into the array
push(@{ $details->{comment_parsed}{"doxygen_$type"} },
$info);
}
# Booooh! Just an ordinary comment
elsif ($line =~ $ordinary_line) {
my $info = $2;
$info = $1 if $pre;
# setting the recognizing of leading spaces
$pre = ($info =~ $pre_begin ? 1 : $pre);
$pre = ($info =~ $pre_end ? 0 : $pre);
$info =~ s(^\s+(</PRE>))($1)i;
# Only add if not an empty line at the beginning
$details->{comment_parsed}{func_desc} .= "$info\n"
unless ($info =~ /^\s*$/ and
$details->{comment_parsed}{func_desc} eq "");
} else {
if (defined $details->{comment_parsed}{unidentified}) {
push(@{ $details->{comment_parsed}{unidentified} },
$line);
} else {
$details->{comment_parsed}{unidentified} = [ $line ];
}
}
}
# Unnecessary linebreaks at the end of the function description
$details->{comment_parsed}{func_desc} =~ s/[\n\s]+$//s
if defined $details->{comment_parsed}{func_desc};
if (defined $details->{comment_parsed}{doxygen_param}) {
# Remove the description from the doxygen_param and
# move into an hash. A sole hash doesn't work, because
# it usually screws up the parameter order
my %param; my @param;
foreach (@{ $details->{comment_parsed}{doxygen_param} }) {
my ($var, $desc) = split(" ",$_,2);
$param{$var} = $desc;
push(@param, $var);
}
$details->{comment_parsed}{doxygen_param} = [ @param ];
$details->{comment_parsed}{doxygen_param_desc} = { %param };
}
if (defined $details->{comment_parsed}{doxygen_defgroup}) {
# Change doxygen_defgroup from array to hash
my %defgroup;
foreach (@{ $details->{comment_parsed}{doxygen_defgroup} }) {
my ($var, $desc) = split(" ",$_,2);
$defgroup{$var} = $desc;
}
$details->{comment_parsed}{doxygen_defgroup} = { %defgroup };
}
if (defined $details->{comment_parsed}{doxygen_ingroup}) {
# There should be a list of all parameters
my @ingroup = ();
foreach (@{ $details->{comment_parsed}{doxygen_ingroup} }) {
push(@ingroup, split());
}
$details->{comment_parsed}{doxygen_ingroup} = [ @ingroup ];
}
foreach (qw(return warning remark)) {
if (defined $details->{comment_parsed}{"doxygen_$_"}) {
# Multiple adjacent @$_ should be concatenated, so
# we can make an scalar out of it. Although we
# actually still disregard the case, that there
# are several non-adjacent @$_s.
$details->{comment_parsed}{"doxygen_$_"} =
join("\n",
@{ $details->{comment_parsed}{"doxygen_$_"} });
}
}
# Dump the output for debugging purposes
# print STDERR "### $details->{perl_name}:\n".
# Dumper $details->{comment_parsed};
# print STDERR "### Original Comment:\n".
# Dumper $details->{comment};
}
# Some more per function information, used in the XS files
my $class = $details->{class};
if ($class) {
my $prefix = $details->{prefix};
$last_prefix = $prefix if $prefix;
if ($details->{name} =~ /^$myprefix/o) {
#e.g. mpxs_Apache__RequestRec_
my $class_prefix = $fmap -> class_c_prefix($class);
if ($details->{name} =~ /$class_prefix/) {
$details->{class_xs_prefix} =
$fmap->class_xs_prefix($class);
}
$details->{class_c_prefix} = $class_prefix;
}
}
}
# Some more information, used in the XS files
my $destructor = $self->typemap->destructor($last_prefix);
my $boot = $self->boot($module);
if ($boot) {
chomp($boot);
$boot =~ s/(\s+$|^\s+)//;
}
my $newxs = $self->{newXS}->{$module};
# Finally do the PDD Dump
my $pdd = {
module => $module,
functions => [ map $$_{perl_name}, @$functions ],
functions_detailed => [ @$functions ],
includes => [ @includes ],
my_xs_prefix => $myprefix,
destructor => $destructor,
boot => $boot,
newXS => $newxs
};
print $fh Dumper $pdd;
close $fh;
$fh = $self->open_class_file($module, '.pod');
$self -> generate_pod($fh, $pdd);
close $fh;
}
# ============================================================================
sub generate {
my $self = shift;
$self->prepare;
# now done by write_missing_makefilepls
#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";
# }
if (!$module)
{
print "WARNING: empty module\n" ;
next ;
}
print "mod $module\n" ;
$self->write_makefilepl($module);
$self->write_xs($module, $functions);
$self->write_pm($module);
$self->write_docs($module, $functions);
}
$self -> write_missing_makefilepls ;
}
# ============================================================================
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;
}
# ============================================================================
=pod
=head2 mapline_elem (o, elem)
Called for each structure element that is written to the map file by
checkmaps. Allows the user to change the element name, for example
adding a different perl name.
Default: returns the element unmodified
=cut
sub mapline_elem { return $_[1] } ;
# ============================================================================
=pod
=head2 mapline_func (o)
Called for each function that is written to the map file by checkmaps. Allows
the user to change the function name, for example adding a different perl
name.
Default: returns the element unmodified
=cut
sub mapline_func { return $_[1] } ;
# ============================================================================
sub checkmaps {
my $self = shift;
my $prefix = shift;
$self = $self -> new if (!ref $self) ;
my $result = $self -> {typemap} -> checkmaps ;
$self -> {typemap} -> writemaps ($result, $prefix) if ($prefix) ;
return $result ;
}
# ============================================================================
sub run {
my $class = shift ;
my $xs = $class -> new;
$xs->generate;
}
1;
__END__