File Coverage

blib/lib/ExtUtils/XSBuilder/WrapXS.pm

Criterion	Covered	Total	%
statement	33	824	4.0
branch	0	326	0.0
condition	0	98	0.0
subroutine	11	74	14.8
pod	18	61	29.5
total	62	1383	4.4

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

=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 = <

/*
 * *********** 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 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</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</Apache/DAV/Resource/Resource_pm> will be included into
the C module.

Default: C</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</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>

=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 = <
$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 = <
$type
$perl_name(obj, val=$default)
    $class obj
    $type_in val
  PREINIT:
    $preinit
$attrs
  CODE:
    RETVAL = ($cast) $address obj->$name;
EOF
            if ($rdonly) {
            $code .= <
    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 .= <
  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

=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 <
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 <
$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__