wrapxs.pm

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

# Copyright 2001-2005 The Apache Software Foundation
#
# Licensed under the Apache License, Version 2.0 (the "License");
# you may not use this file except in compliance with the License.
# You may obtain a copy of the License at
#
#     http://www.apache.org/licenses/LICENSE-2.0
#
# Unless required by applicable law or agreed to in writing, software
# distributed under the License is distributed on an "AS IS" BASIS,
# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
# See the License for the specific language governing permissions and
# limitations under the License.
#
package ModPerl::WrapXS;

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

use constant GvUNIQUE => 0; #$] >= 5.008;
use Apache::TestTrace;
use Apache2::Build ();
use ModPerl::Code ();
use ModPerl::TypeMap ();
use ModPerl::MapUtil qw(function_table xs_glue_dirs);
use File::Path qw(rmtree mkpath);
use Cwd qw(fastcwd);
use Data::Dumper;
use File::Spec::Functions qw(catfile catdir);

our $VERSION = '0.01';

my (@xs_includes) = ('mod_perl.h',
                    map "modperl_xs_$_.h", qw(sv_convert util typedefs));

my @global_structs = qw(perl_module);

my $build = Apache2::Build->build_config;
push @global_structs, 'MP_debug_level' unless Apache2::Build::WIN32;

sub new {
    my $class = shift;

    my $self = bless {
       typemap   => ModPerl::TypeMap->new,
       includes  => \@xs_includes,
       glue_dirs => [xs_glue_dirs()],
    }, $class;

    $self->typemap->get;
    $self;
}

sub typemap  { shift->{typemap} }

sub includes { shift->{includes} }

sub function_list {
    my $self = shift;
    my (@list) = @{ function_table() };

    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 get_functions {
    my $self = shift;
    my $typemap = $self->typemap;

    for my $entry (@{ $self->function_list() }) {
        my $func = $typemap->map_function($entry);
        #print "FAILED to map $entry->{name}\n" unless $func;
        next unless $func;

        my ($name, $module, $class, $args) =
          @{ $func } { qw(perl_name module class args) };

        $self->{XS}->{ $module } ||= [];

        #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 = $xs_parms) =~ s/=[^,]+//g; #strip defaults

        my $proto = join "\n",
          (map "    $_->{type} $_->{name}", @$args), "";

        my ($dispatch, $orig_args) =
          @{ $func } {qw(dispatch orig_args)};

        if ($dispatch =~ /^MPXS_/) {
            $name =~ s/^mpxs_//;
            $name =~ s/^$func->{prefix}//;
            push @{ $self->{newXS}->{ $module } },
              ["$class\::$name", $dispatch];
            next;
        }

        my $passthru = @$args && $args->[0]->{name} eq '...';
        if ($passthru) {
            $parms = '...';
            $proto = '';
        }

        my $return_type =
          $name =~ /^DESTROY$/ ? 'void' : $func->{return_type};

        my $attrs = $self->attrs($name);

        my $code = <<EOF;
$return_type
$name($xs_parms)
$proto
$attrs
EOF

        if ($dispatch || $orig_args || $func->{thx}) {
            my $thx = $func->{thx} ? 'aTHX_ ' : "";

            if ($dispatch) {
                $thx = 'aTHX_ ' if $dispatch =~ /^mpxs_/i;
            }
            else {
                if ($orig_args and @$orig_args == @$args) {
                    #args were reordered
                    $parms = join ', ', @$orig_args;
                }

                $dispatch = $func->{name};
            }

            if ($passthru) {
                $thx ||= 'aTHX_ ';
                $parms = 'items, MARK+1, SP';
            }

            $thx =~ s/_ $// unless $parms;

            my $retval = $return_type eq 'void' ?
              ["", ""] : ["RETVAL = ", "OUTPUT:\n    RETVAL\n"];

            $code .= <<EOF;
    CODE:
    $retval->[0]$dispatch($thx$parms);

    $retval->[1]
EOF
        }

        $func->{code} = $code;
        push @{ $self->{XS}->{ $module } }, $func;
    }
}

sub get_value {
    my $e = shift;
    my $val = 'val';

    if ($e->{class} eq 'PV') {
        if (my $pool = $e->{pool}) {
            $pool .= '(obj)';
            $val = "(SvOK(ST(1)) ?
                    apr_pstrndup($pool, val, val_len) : NULL)"
        }
    }

    return $val;
}

sub get_structures {
    my $self = shift;
    my $typemap = $self->typemap;

    require Apache2::StructureTable;
    for my $entry (@$Apache2::StructureTable) {
        my $struct = $typemap->map_structure($entry);
        next unless $struct;

        my $class = $struct->{class};

        for my $e (@{ $struct->{elts} }) {
            my ($name, $default, $type, $access_mode) =
              @{$e}{qw(name default type access_mode)};

            (my $cast = $type) =~ s/:/_/g;
            my $val = get_value($e);

            my $type_in = $type;
            my $preinit = "/*nada*/";
            if ($e->{class} eq 'PV' and $val ne 'val') {
                $type_in =~ s/char/char_len/;
                $preinit = "STRLEN val_len;";
            }

            my $attrs = $self->attrs($name);

            my $code;
            if ($access_mode eq 'ro') {
                $code = <<EOF;
$type
$name(obj)
    $class obj

$attrs

    CODE:
    RETVAL = ($cast) obj->$name;

    OUTPUT:
    RETVAL

EOF
            }
            elsif ($access_mode eq 'rw' or $access_mode eq 'r+w_startup') {

                my $check_runtime = $access_mode eq 'rw'
                    ? ''
                    : qq[MP_CROAK_IF_THREADS_STARTED("setting $name");];

                $code = <<EOF;
$type
$name(obj, val=$default)
    $class obj
    $type_in val

    PREINIT:
    $preinit
$attrs

    CODE:
    RETVAL = ($cast) obj->$name;

    if (items > 1) {
         $check_runtime
         obj->$name = ($cast) $val;
    }

    OUTPUT:
    RETVAL

EOF
            }
            elsif ($access_mode eq 'r+w_startup_dup') {

                my $convert = $cast !~ /\bchar\b/
                    ? "mp_xs_sv2_$cast"
                    : "SvPV_nolen";

                $code = <<EOF;
$type
$name(obj, val=Nullsv)
    $class obj
    SV *val

    PREINIT:
    $preinit
$attrs

    CODE:
    RETVAL = ($cast) obj->$name;

    if (items > 1) {
         SV *dup = get_sv("_modperl_private::server_rec_$name", TRUE);
         MP_CROAK_IF_THREADS_STARTED("setting $name");
         sv_setsv(dup, val);
         obj->$name = ($cast)$convert(dup);
    }

    OUTPUT:
    RETVAL

EOF
            }
            elsif ($access_mode eq 'rw_char_undef') {
                my $pool = $e->{pool} 
                    or die "rw_char_undef accessors need pool";
                $pool .= '(obj)';
# XXX: not sure where val=$default is coming from, but for now use
# hardcoded Nullsv
                $code = <<EOF;
$type
$name(obj, val_sv=Nullsv)
    $class obj
    SV *val_sv

    PREINIT:
$attrs

    CODE:
    RETVAL = ($cast) obj->$name;

    if (val_sv) {
        if (SvOK(val_sv)) {
            STRLEN val_len;
            char *val = (char *)SvPV(val_sv, val_len);
            obj->$name = apr_pstrndup($pool, val, val_len);
        }
        else {
            obj->$name = NULL;
        }
    }

    OUTPUT:
    RETVAL

EOF
            }

            push @{ $self->{XS}->{ $struct->{module} } }, {
               code  => $code,
               class => $class,
               name  => $name,
            };
        }
    }
}

sub prepare {
    my $self = shift;
    $self->{DIR} = 'WrapXS';
    $self->{XS_DIR} = catdir fastcwd(), 'xs';

    my $verbose = Apache::TestTrace::trace_level() eq 'debug' ? 1 : 0;

    if (-e $self->{DIR}) {
        rmtree([$self->{DIR}], $verbose, 1);
    }

    mkpath [$self->{DIR}], $verbose, 0755;
}

sub class_dirname {
    my ($self, $class) = @_;
    my ($base, $sub) = split '::', $class;
    return "$self->{DIR}/$base" unless $sub; #Apache2 | APR
    return $sub if $sub eq $self->{DIR}; #WrapXS
    return "$base/$sub";
}

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

    my $dirname = $self->class_dirname($class);
    my $dir = ($dirname =~ m:/: and $dirname !~ m:^$self->{DIR}:) ?
      catdir($self->{DIR}, $dirname) : $dirname;

    unless (-d $dir) {
        mkpath [$dir], 0, 0755;
        debug "mkdir.....$dir";
    }

    $dir;
}

sub class_file {
    my ($self, $class, $file) = @_;
    catfile $self->class_dir($class), $file;
}

sub cname {
    my ($self, $class) = @_;
    $class =~ s/:/_/g;
    $class;
}

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: $!";
    debug "writing...$name";

    return $fh;
}

sub module_version {
    local $_ = shift;
    require mod_perl2;
    # XXX: for now APR gets its libapr-0.9 version
    return /^APR/ ? "0.009000" : "$mod_perl2::VERSION";
}

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

    my $fh = $self->open_class_file($class, 'Makefile.PL');

    my $includes = $self->includes;
    my $xs = (split '::', $class)[-1] . '.c';
    my $deps = {$xs => ""};

    if (my $mod_h = $self->mod_h($class, 1)) {
        $deps->{$xs} .= " $mod_h";
    }

    local $Data::Dumper::Terse = 1;
    $deps = Dumper $deps;

    my $noedit_warning = $self->ModPerl::Code::noedit_warning_hash();
    require mod_perl2;
    my $version = module_version($class);

    print $fh <<EOF;
$noedit_warning

use lib qw(../../../lib); #for Apache2::BuildConfig
use ModPerl::BuildMM ();

ModPerl::BuildMM::WriteMakefile(
    'NAME'    => '$class',
    'VERSION' => '$version',
    'depend'  => $deps,
);
EOF

    close $fh;
}

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_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 ($base, $sub) = split '::', $module;
    my $mod_pm = "$dirname/${sub}_pm";