typemap.pm

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

package ExtUtils::XSBuilder::TypeMap;

use strict;
use warnings FATAL => 'all';

use ExtUtils::XSBuilder::FunctionMap ();
use ExtUtils::XSBuilder::CallbackMap ();
use ExtUtils::XSBuilder::StructureMap ();
use ExtUtils::XSBuilder::MapUtil qw(list_first function_table structure_table callback_table callback_hash);
use Data::Dumper ;

our @ISA = qw(ExtUtils::XSBuilder::MapBase);

sub new {
    my $class = shift;
    my $self = bless { INCLUDE => [], wrapxs => shift }, $class;

    $self->{function_map}  = ExtUtils::XSBuilder::FunctionMap ->new ($self -> {wrapxs}),
    $self->{structure_map} = ExtUtils::XSBuilder::StructureMap->new ($self -> {wrapxs}),
    $self->{callback_map}  = ExtUtils::XSBuilder::CallbackMap ->new ($self -> {wrapxs}),

    $self->get;
    $self;
}

my %special = map { $_, 1 } qw(UNDEFINED NOTIMPL CALLBACK);

sub special {
    my($self, $class) = @_;
    return $special{$class};
}

sub function_map  { shift->{function_map}->get  }
sub structure_map { shift->{structure_map}->get }
sub callback_map  { shift->{callback_map}->get }

sub parse {
    my($self, $fh, $map) = @_;

    while ($fh->readline) {
        if (/E=/) {
            my %args = $self->parse_keywords($_);
            while (my($key,$val) = each %args) {
                push @{ $self->{$key} }, $val;
            }
            next;
        }

        my @aliases;
        my($type, $class, $typemapid, $aliastypes, $malloctype) = split /\s*\|\s*/, $_, 5;
        if (!$typemapid && $class)
            {
            if ($class =~ /::/) {
                $typemapid = 'T_PTROBJ';
                }
            else {
                $typemapid = "T_$class";
            }
        }
        $class ||= 'UNDEFINED';

        if ($type =~ s/^struct\s+(.*)/$1/) {
            push @aliases,
              "$type *",        "const $type *",
              $type,            "const $type", 
              "struct $type",   "const struct $type",
              "struct $type *", "const struct $type *",
              "$type **",       "const $type **" ;

            my $cname = $class;
            if ($cname =~ s/::/__/g) {
                push @{ $self->{typedefs} }, [$type, $cname];
            }
        }
        elsif ($type =~ /_t$/) {
            push @aliases, $type, "$type *", "const $type *";
        }
        else {
            push @aliases, $type;
        }

        my $t = { class => $class,
                  typemapid => $typemapid } ;
        $t -> {aliastypes} = [ split (/\s*,\s*/, $aliastypes) ]  if ($aliastypes) ;
        $t -> {malloctype} = $malloctype if ($malloctype) ;

        for (@aliases) {
            $map->{$_} = $t ; 
        }
    }
}

sub get {
    my $self = shift;

    $self->{map} ||= $self->parse_map_files;
}

my $ignore = join '|', qw{
ap_LINK ap_HOOK _ UINT union._
union.block_hdr cleanup process_chain
iovec struct.rlimit Sigfunc in_addr_t
};

sub should_ignore {
    my($self, $type) = @_;
    return 1 if $type =~ /^($ignore)/o;
}

sub is_callback {
    my($self, $type) = @_;
    return 1 if $type =~ /\(/ and $type =~ /\)/; #XXX: callback
}

sub exists {
    my($self, $type) = @_;

    return 1 if $self->is_callback($type) || $self->should_ignore($type);

    $type =~ s/\[\d+\]$//; #char foo[64]

    return exists $self->get->{$type};
}

sub map_type {
    my($self, $type, $quiet) = @_;
    my $t = $self->get->{$type};
    my $class = $t -> {class} ;

    unless ($class and ! $self->special($class))
        {
        print "WARNING: Type '$type' not in mapfile\n" if (!$quiet);
        return undef ;
        }
    if ($class =~ /(.*?)::$/) {
        return $1 ;
    }
    if ($class =~ /::/) {
        return $class;
    }
    else {
        return $type;
    }
}

sub map_malloc_type {
    my($self, $type) = @_;
    my $t = $self->get->{$type};
    return $t -> {malloctype} ;
}

sub map_class {
    my($self, $type) = @_;
    my $t = $self->get->{$type};
    my $class = $t -> {class} ;

    return unless $class and ! $self->special($class);
    if ($class =~ /(.*?)::$/) {
        return $1 ;
    }
    return $class ;
}

sub null_type {
    my($self, $type) = @_;
    my $t = $self->get->{$type};
    my $class = $t -> {class} ;

    if ($class =~ /^[INU]V/) {
        return '0';
    }
    elsif ($class =~ /^(U_)?CHAR$/) {
        return '0'; # xsubpp seems to mangle q{'\0'}
    }
    else {
        return 'NULL';
    }
}

sub can_map {
    my $self = shift;
    my $map = shift;
    my $return_type = shift ;

    if (!$self->map_type($return_type))
        {
        print "WARNING: Cannot map return type $return_type for function ", $map->{name} || '???', "\n" ;
        return undef ;
        }

    return 1 if ($map->{argspec}) ;

    for (@_) {
        if (!$self->map_type($_))
            {
            print "WARNING: Cannot map type $_ for function ", $map->{name} || '???', "\n" ;
            return undef ;
            }
    }

    return 1;
}

sub map_arg {
    my($self, $arg) = @_;
    #print Dumper ($arg), 'map ', $self->map_type($arg->{type}), "\n" ;
    return {
       name    => $arg->{name},
       default => $arg->{default},
       type    => $self->map_type($arg->{type}) || $arg->{type},
       rtype   => $arg->{type},
       class   => $self->{map}->{$arg->{type}}->{class} || "",
    }
}

sub map_args {
    my($self, $func, $entry) = @_;

    #my $entry = $self->function_map->{ $func->{name} };
    my $argspec = $entry->{argspec};
    my $args = [];
    my $retargs = [];

    if ($argspec) {
        $entry->{orig_args} = [ map $_->{name}, @{ $func->{args} } ];

        #print "argspec ", Dumper($argspec) ;
        for my $arg (@$argspec) {
            my $default;
            my $return  ;
            if ($arg =~ /^<(.*?)$/) {
                $arg = $1 ;
                $return = 1 ;
                }
            
            ($arg, $default) = split /=/, $arg, 2;
            my($type, $name) ;
            if ($arg =~ /^(.+)\s*:\s*(.+)$/)
                {
                $type = $1 ;
                $name = $2 ;
                }

            #my($type, $name) = split /:(?:[^:])/, $arg, 2;

            my $arghash ;
            if ($type and $name) {
                $arghash = {
                   name => $name,
                   type => $type,
                   default => $default,
                };
            }
            else {
                my $e = list_first { $_->{name} eq $arg } @{ $func->{args} };
                if ($e) {
                    $arghash = { %$e, default => $default};
                }
                elsif ($arg eq '...') {
                    $arghash = { name => '...', type => 'SV *'};
                }
                else {
                    warn "bad argspec: $func->{name} ($arg)\n", Dumper ($func->{args}) ;
                }
            }
            if ($arghash){
                if ($return) {
                    $arghash -> {return} = 1 ;
                    $arghash -> {type} =~ s/\s*\*$// ;
                    push @$retargs, $arghash  ;
                } 
                else {
                    push @$args, $arghash  ;
                }
            }
        }
    }
    else {
        $args = $func->{args};
    }

    return ([ map $self->map_arg($_), @$args ], [ map $self->map_arg($_), @$retargs ]) ;
}

# ============================================================================

sub map_cb_or_func {
    my($self, $func, $map, $class) = @_;

    return unless $map;

    return unless $self->can_map($map, $func->{return_type} || 'void',
                                 map $_->{type}, @{ $func->{args} });
    my ($mfargs, $mfretargs) = $self->map_args($func, $map) ;

    my $mf = {
       name        => $func->{name},
       comment     => $func->{comment},
       return_type => $self->map_type($map->{return_type} ||
                                      $func->{return_type} || 'void'),
       args        => $mfargs,
       retargs     => $mfretargs,
       perl_name   => $map->{name},
    };

    for (qw(dispatch argspec dispatch_argspec orig_args prefix)) {
        $mf->{$_} = $map->{$_};
    }

    $mf->{class} = $class if ($class) ;

    unless ($mf->{class}) {
        $mf->{class} = $map->{class} || $self->first_class($mf);
        #print "GUESS class=$mf->{class} for $mf->{name}\n";
    }

    $mf->{prefix} ||= $self -> {function_map} -> guess_prefix($mf);

    $mf->{module} = $map->{module} || $mf->{class};

    $mf;
}

# ============================================================================

sub map_function {
    my($self, $func) = @_;

    my $map = $self->function_map->{ $func->{name} };
    return unless $map;

    return $self -> map_cb_or_func ($func, $map) ;
}

# ============================================================================

sub map_callback {
    my($self, $callb, $class) = @_;

    my $name = $callb -> {type} ;
    my $callback = callback_hash ($self -> {wrapxs}) -> {$name} ;
    #print $callb -> {name} || '???' ,"   $name -> ", $callback || '-', "\n" ;
    return unless $callback;

    my $map = $self->callback_map->{ $name };
    #print "$name -> map=", $map || '-', "\n" ;
    return unless $map;

    my $cb = $self -> map_cb_or_func ($callback, $map, $class) ;

    return unless $cb ;

    my $orig_args = $cb -> {orig_args} ;
    $orig_args = [ map $_->{name}, @{ $cb->{args} } ] if (!$orig_args) ;
    
    my %args    = map { $_->{name} => $_ } @{ $cb->{args} } ;
    my %retargs = map { $_->{name} => $_ } @{ $cb->{retargs} } ;

    #print "mcb ", Dumper($cb), " cba ", Dumper($callback->{args}) , " args ", Dumper(\%args) ;

    $cb -> {orig_args} = [ map ($retargs{$_}?"\&$_":(($args{$_}{type} !~ /::/) || ($args{$_}{rtype} =~ /\*$/)?
                                         $_:"*$_"), @{ $orig_args }) ];

    my $cbargs      = [ { type => $class, name => '__self'} ] ;
    push @$cbargs, @{ $cb->{args} } if (@{ $cb->{args}}) ;
    $cb->{args} = $cbargs ;

    #print 'func', Dumper($callback), 'map', Dumper($map), 'cb', Dumper($cb) ;

    return $cb ;
}

# ============================================================================

sub map_structure {
    my($self, $struct) = @_;

    my($class, @elts);
    my $stype = $struct->{type};

    return unless ($class = $self->map_type($stype)) ;

    my $module = $self->{structure_map}->{MODULES}->{$stype} || $class ;
    for my $e (@{ $struct->{elts} }) {
        my($name, $type) = ($e->{name}, $e->{type});
        my $rtype;
        my $mapping ;

        if (!exists ($self->structure_map->{$stype}->{$name}))
            {
            if (!$name)
                {
                print "WARNING: The following struct element is not in mapfile and has no name\n", Dumper ($e) ;
                }
            else
                {
                print "WARNING: $name not in mapfile\n" ;
                }
            next ;
            }
        if (!($mapping = $self->structure_map->{$stype}->{$name}))
            {
            print "WARNING: $stype for $name not in mapfile\n" ;
            next ;
            }
        my $mallocmap = $self->structure_map->{$stype}{-malloc} ;
        my $freemap   = $self->structure_map->{$stype}{-free} ;

        #print 'mapping: ', Dumper($mapping, $type) ;

        if ($rtype = $self->map_type($type, 1)) {
            #print "rtype=$rtype\n" ;
            my $malloctype = $self->map_malloc_type($type) ;
            push @elts, {
               name    => $name,
               perl_name    => $mapping -> {perl_name} || $name,
               comment => $e -> {comment},
               type    => $mapping -> {type} || $rtype,
               rtype   => $type,
               default => $self->null_type($type),
               pool    => $self->class_pool($class),
               class   => $self->{map}->{$type}{class} || "",
               $malloctype?(malloc  => $mallocmap -> {$malloctype}):(), 
               $malloctype?(free    => $freemap -> {$malloctype}):(), 
            };
    
            #print Dumper($elts[-1], $stype, $mallocmap, $self->map_malloc_type($type)) ;
        }
        elsif ($rtype = $self->map_callback($e, $class)) {
            push @elts, {
               name    => $name,
               perl_name    => $mapping -> {perl_name} || $name,
               func    => { %$rtype, name => $name, perl_name => $rtype->{alias} || $name, module => $module, dispatch => "(*__self->$name)", comment => $e -> {comment}},
               rtype   => $type,
               default => 'NULL',
               #pool    => $self->class_pool($class),
               class   => $class || "",
               callback => 1,
            };
        }
        else
            {
            print "WARNING: Type '$type' for struct memeber '$name' in not in types mapfile\n" ;
            }

    }

    return {
       module       => $module,
       class        => $class,
       type         => $stype,