wrapxs.pm

视频监控网络部分的协议ddns,的模块的实现代码,请大家大胆指正.

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 ;