wrapxs.pm

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

    for ($self->{XS_DIR}, @{ $self->{glue_dirs} }) {
        my $file = "$_/$mod_pm";
        $mod_pm = $file if $complete;
        return $mod_pm if -e $file;
    }

    undef;
}

sub class_c_prefix {
    my $class = shift;
    $class =~ s/:/_/g;
    $class;
}

sub class_mpxs_prefix {
    my $class = shift;
    my $class_prefix = class_c_prefix($class);
    "mpxs_${class_prefix}_";
}

sub needs_prefix {
    my $name = shift;
    $name !~ /^(ap|apr|mpxs)_/i;
}

sub make_prefix {
    my ($name, $class) = @_;
    my $class_prefix = class_mpxs_prefix($class);
    return $name if $name =~ /^$class_prefix/;
    $class_prefix . $name;
}

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 = '    mpxs_' . $self->cname($module) . "_BOOT(aTHX);\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: unique\n" if GvUNIQUE;
    $str;
}

sub write_xs {
    my ($self, $module, $functions) = @_;

    my $fh = $self->open_class_file($module, '.xs');
    print $fh $self->ModPerl::Code::noedit_warning_c(), "\n";
    print $fh "\n#define MP_IN_XS\n\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 = "";

    for my $func (@$functions) {
        my $class = $func->{class};
        my $prefix = $func->{prefix};
        $last_prefix = $prefix if $prefix;

        if ($func->{name} =~ /^mpxs_/) {
            #e.g. mpxs_Apache2__RequestRec_
            my $class_prefix = class_c_prefix($class);
            if ($func->{name} =~ /$class_prefix/) {
                $prefix = class_mpxs_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 "MODULE = $module\n";
    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 (sort { $a->[0] cmp $b->[0] } @$newxs) {
            print $fh qq{   cv = newXS("$xs->[0]", $xs->[1], __FILE__);\n};
            print $fh qq{   GvUNIQUE_on(CvGV(cv));\n} if GvUNIQUE;
        }
    }

    if ($module eq 'APR::Pool') {
        print $fh "    modperl_opt_interp_unselect = APR_RETRIEVE_OPTIONAL_FN(modperl_interp_unselect);\n\n";
    }

    close $fh;
}

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];
    unless (-e "lib/$base/XSLoader.pm") {
        $base = 'Apache2';
    }
    my $loader = join '::', $base, 'XSLoader';

    my $fh = $self->open_class_file($module, '.pm');
    my $noedit_warning = $self->ModPerl::Code::noedit_warning_hash();
    my $use_apr = ($module =~ /^APR::\w+$/) ? 'use APR ();' : '';
    my $version = module_version($module);

    print $fh <<EOF;
$noedit_warning

package $module;

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

$isa
$use_apr
use $loader ();
our \$VERSION = '$version';
$loader\::load __PACKAGE__;

$code

1;
__END__
EOF
}

my %typemap = (
    'Apache2::RequestRec' => 'T_APACHEOBJ',
    'apr_time_t'         => 'T_APR_TIME',
    'APR::Table'         => 'T_HASHOBJ',
    'APR::Pool'          => 'T_POOLOBJ',
    'apr_size_t *'       => 'T_UVPTR',
);

sub write_typemap {
    my $self = shift;
    my $typemap = $self->typemap;
    my $map = $typemap->get;
    my %seen;

    my $fh = $self->open_class_file('ModPerl::WrapXS', 'typemap');
    print $fh $self->ModPerl::Code::noedit_warning_hash(), "\n";

    my %entries = ();
    my $max_key_len = 0;
    while (my ($type, $class) = each %$map) {
        $class ||= $type;
        next if $seen{$type}++ || $typemap->special($class);

        if ($class =~ /::/) {
            $entries{$class} = $typemap{$class} || 'T_PTROBJ';
            $max_key_len = length $class if length $class > $max_key_len;
        }
        else {
            $entries{$type} = $typemap{$type} || "T_$class";
            $max_key_len = length $type if length $type > $max_key_len;
        }
    }

    for (sort keys %entries) {
        printf $fh "%-${max_key_len}s %s\n", $_, $entries{$_};
    }

    close $fh;
}

sub write_typemap_h_file {
    my ($self, $method) = @_;

    $method = $method . '_code';
    my ($h, $code) = $self->typemap->$method();
    my $file = catfile $self->{XS_DIR}, $h;

    open my $fh, '>', $file or die "open $file: $!";
    print $fh $self->ModPerl::Code::noedit_warning_c(), "\n";
    print $fh $code;
    close $fh;
}

sub write_lookup_method_file {
    my $self = shift;

    my %map = ();
    while (my ($module, $functions) = each %{ $self->{XS} }) {
        my $last_prefix = "";
        for my $func (@$functions) {
            my $class = $func->{class};
            my $prefix = $func->{prefix};
            $last_prefix = $prefix if $prefix;

            my $name = $func->{perl_name} || $func->{name};
            $name =~ s/^DEFINE_//;

            if ($name =~ /^mpxs_/) {
                #e.g. mpxs_Apache2__RequestRec_
                my $class_prefix = class_c_prefix($class);
                if ($name =~ /$class_prefix/) {
                    $prefix = class_mpxs_prefix($class);
                }
            }
            elsif ($name =~ /^ap_sub_req/) {
                $prefix = 'ap_sub_req_';
            }

            $name =~ s/^$prefix// if $prefix;

            push @{ $map{$name} }, [$module, $class];
        }

        # pure XS wrappers don't have the information about the
        # arguments they receive, since they manipulate the arguments
        # stack directly. therefore for these methods we can't tell
        # what are the objects they are invoked on
        for my $xs (@{ $self->{newXS}->{$module} || []}) {
            push @{ $map{$1} }, [$module, undef] if $xs->[0] =~ /.+::(.+)/;
        }
    }

    local $Data::Dumper::Terse    = 1;
    local $Data::Dumper::Sortkeys = 1;
    $Data::Dumper::Terse    = $Data::Dumper::Terse;    # warn
    $Data::Dumper::Sortkeys = $Data::Dumper::Sortkeys; # warn
    my $methods = Dumper(\%map);
    $methods =~ s/\n$//;

    my $package = "ModPerl::MethodLookup";
    my $file = catfile "lib", "ModPerl", "MethodLookup.pm";
    debug "creating $file";
    open my $fh, ">$file" or die "Can't open $file: $!";

    my $noedit_warning = $self->ModPerl::Code::noedit_warning_hash();

    print $fh <<EOF;
$noedit_warning
package $package;

use strict;
use warnings;

my \$methods = $methods;

EOF

    print $fh <<'EOF';

use base qw(Exporter);
use mod_perl2;

our @EXPORT = qw(print_method print_module print_object);
our $VERSION = $mod_perl2::VERSION;
use constant MODULE => 0;
use constant OBJECT  => 1;

my $modules;
my $objects;

sub _get_modules {
    for my $method (sort keys %$methods) { 
        for my $item ( @{ $methods->{$method} }) {
            push @{ $modules->{$item->[MODULE]} }, [$method, $item->[OBJECT]];
        }
    }
}

sub _get_objects {
    for my $method (sort keys %$methods) { 
        for my $item ( @{ $methods->{$method} }) {
            next unless defined $item->[OBJECT];
            push @{ $objects->{$item->[OBJECT]} }, [$method, $item->[MODULE]];
        }
    }
}

# if there is only one replacement method in 2.0 API we can
# automatically lookup it, up however if there are more than one
# (e.g. new()), we need to use a fully qualified value here
# of course the same if the package is not a mod_perl one.
#
# the first field represents the replacement method or undef if none
# exists, the second field is for extra comments (e.g. when there is
# no replacement method)
my $methods_compat = {
    # Apache2::
    gensym            => ['Symbol::gensym',
                          'or use "open my $fh, $file"'],
    module            => ['Apache2::Module::loaded',
                          ''],
    define            => ['exists_config_define',
                          ''],
    httpd_conf        => ['add_config',
                          ''],
    SERVER_VERSION    => ['get_server_version',
                          ''],
    can_stack_handlers=> [undef,
                          'there is no more need for that method in mp2'],

    # Apache2::RequestRec
    soft_timeout      => [undef,
                          'there is no more need for that method in mp2'],
    hard_timeout      => [undef,
                          'there is no more need for that method in mp2'],
    kill_timeout      => [undef,
                          'there is no more need for that method in mp2'],
    reset_timeout     => [undef,
                          'there is no more need for that method in mp2'],
    cleanup_for_exec  => [undef,
                          'there is no more need for that method in mp2'],
    send_http_header  => ['content_type',
                          ''],
    header_in         => ['headers_in',
                          'this method works in mod_perl 1.0 too'],
    header_out        => ['headers_out',
                          'this method works in mod_perl 1.0 too'],
    err_header_out    => ['err_headers_out',
                          'this method works in mod_perl 1.0 too'],
    register_cleanup  => ['cleanup_register',
                          ''],
    post_connection   => ['cleanup_register',
                          ''],
    content           => [undef, # XXX: Apache2::Request::what?
                          'use CGI.pm or Apache2::Request instead'],
    clear_rgy_endav   => ['special_list_clear',
                          ''],
    stash_rgy_endav   => [undef,
                          ''],
    run_rgy_endav     => ['special_list_call',
                          'this method is no longer needed'],
    seqno             => [undef,
                          'internal to mod_perl 1.0'],
    chdir_file        => [undef, # XXX: to be resolved
                          'temporary unavailable till the issue with chdir' .
                          ' in the threaded env is resolved'],
    log_reason        => ['log_error',
                          'not in the Apache 2.0 API'],
    READLINE          => [undef, # XXX: to be resolved
                          ''],
    send_fd_length    => [undef,
                          'not in the Apache 2.0 API'],
    send_fd           => ['sendfile',
                          'requires an offset argument'],
    is_main           => ['main',
                          'not in the Apache 2.0 API'],
    cgi_var           => ['subprocess_env',
                          'subprocess_env can be used with mod_perl 1.0'],
    cgi_env           => ['subprocess_env',
                          'subprocess_env can be used with mod_perl 1.0'],
    each_byterange    => [undef,
                          'now handled internally by ap_byterange_filter'],
    set_byterange     => [undef,
                          'now handled internally by ap_byterange_filter'],

    # Apache::File
    open              => [undef,
                          ''],
    close             => [undef, # XXX: also defined in APR::Socket
                          ''],
    tmpfile           => [undef,
                          'not in the Apache 2.0 API, ' .
                          'use File::Temp instead'],

    # Apache::Util
    size_string       => ['format_size',
                          ''],
    escape_uri        => ['unescape_path',
                          ''],
    escape_url        => ['escape_path',
                          'and requires a pool object'],
    unescape_uri      => ['unescape_url',
                          ''],
    unescape_url_info => [undef,
                          'use CGI::Util::unescape() instead'],
    escape_html       => [undef, # XXX: will be ap_escape_html
                          'ap_escape_html now requires a pool object'],
    parsedate         => ['parse_http',
                          ''],
    validate_password => ['password_validate',
                          ''],

    # Apache::Table
    #new               => ['make',
    #                      ''], # XXX: there are other 'new' methods

    # Apache::Connection
    auth_type         => ['ap_auth_type',
                          'now resides in the request object'],
};

sub avail_methods_compat {
    return keys %$methods_compat;
}

sub avail_methods {
    return keys %$methods;
}

sub avail_modules {
    my %modules = ();
    for my $method (keys %$methods) {
        for my $item ( @{ $methods->{$method} }) {
            $modules{$item->[MODULE]}++;
        }
    }
    return keys %modules;
}