Beta Shell v2.0

File Manager

~ /usr/share/perl5/vendor_perl/ExtUtils/XSBuilder
Name	Size	Perms	Modified	Actions
[ .. / .. ]
C	-	drwxr-xr-x	2022-02-23 11:31:13	Del
CallbackMap.pm	2.26 KB	-rw-r--r--	2005-08-11 14:57:55	Edit Del
FunctionMap.pm	5.63 KB	-rw-r--r--	2005-08-11 14:53:31	Edit Del
MapUtil.pm	5.63 KB	-rw-r--r--	2002-01-15 15:31:21	Edit Del
PODTemplate.pm	1.73 KB	-rw-r--r--	2004-04-02 05:26:36	Edit Del
ParseSource.pm	14.81 KB	-rw-r--r--	2005-08-22 18:39:43	Edit Del
StructureMap.pm	4.46 KB	-rw-r--r--	2005-08-30 04:16:50	Edit Del
TypeMap.pm	25.88 KB	-rw-r--r--	2006-04-08 13:04:47	Edit Del
WrapXS.pm	56.33 KB	-rw-r--r--	2005-08-31 04:59:00	Edit Del
Editing: WrapXS.pm (56.33 KB)

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__