wrapxs.pm

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

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