wrapxs.pm

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

    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" ;
            }