wrapxs.pm

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

sub preload_all_modules {
    _get_modules() unless $modules;
    eval "require $_" for keys %$modules;
}

sub _print_func {
    my $func = shift;
    my @args = @_ ? @_ : @ARGV;
    no strict 'refs';
    print( ($func->($_))[0]) for @args;
}

sub print_module { _print_func('lookup_module', @_) }
sub print_object { _print_func('lookup_object', @_) }

sub print_method {
    my @args = @_ ? @_ : @ARGV;
    while (@args) {
         my $method = shift @args;
         my $object = (@args && 
             (ref($args[0]) || $args[0] =~ /^(Apache2|ModPerl|APR)/))
             ? shift @args
             : undef;
         print( (lookup_method($method, $object))[0]);
    }
}

sub sep { return '-' x (shift() + 20) . "\n" }

# what modules contain the passed method.
# an optional object or a reference to it can be passed to help
# resolve situations where there is more than one module containing
# the same method. Inheritance is supported.
sub lookup_method {
    my ($method, $object) = @_;

    unless (defined $method) {
        my $hint = "No 'method' argument was passed\n";
        return ($hint);
    }

    # strip the package name for the fully qualified method
    $method =~ s/.+:://;

    if (exists $methods_compat->{$method}) {
        my ($replacement, $comment) = @{$methods_compat->{$method}};
        my $hint = "'$method' is not a part of the mod_perl 2.0 API\n";
        $comment = length $comment ? " $comment\n" : "";

        # some removed methods have no replacement
        return $hint . "$comment" unless defined $replacement;

        $hint .= "use '$replacement' instead. $comment";

        # if fully qualified don't look up its container
        return $hint if $replacement =~ /::/;

        my ($modules_hint, @modules) = lookup_method($replacement, $object);
        return $hint . $modules_hint;
    }
    elsif (!exists $methods->{$method}) {
        my $hint = "Don't know anything about method '$method'\n";
        return ($hint);
    }

    my @items = @{ $methods->{$method} };
    if (@items == 1) {
        my $module = $items[0]->[MODULE];
        my $hint = "To use method '$method' add:\n" . "\tuse $module ();\n";
        # we should really check that the method matches the object if
        # any was passed, but it may not always work
        return ($hint, $module);
    }
    else {
        if (defined $object) {
            my $class = ref $object || $object;
            for my $item (@items) {
                # real class or inheritance
                if ($class eq $item->[OBJECT] or
                    (ref($object) && $object->isa($item->[OBJECT]))) {
                    my $module = $item->[MODULE];
                    my $hint = "To use method '$method' add:\n" .
                        "\tuse $module ();\n";
                    return ($hint, $module);
                }
            }
            # fall-through
            local $" = ", ";
            my @modules = map $_->[MODULE], @items;
            my $hint = "Several modules (@modules) contain method '$method' " .
                "but none of them matches class '$class';\n";
            return ($hint);

        }
        else {
            my %modules = map { $_->[MODULE] => 1 } @items;
            # remove dups if any (e.g. $s->add_input_filter and
            # $r->add_input_filter are loaded by the same Apache2::Filter)
            my @modules = keys %modules;
            my $hint;
            if (@modules == 1) {
                $hint = "To use method '$method' add:\n\tuse $modules[0] ();\n";
                return ($hint, $modules[0]);
            }
            else {
                $hint = "There is more than one class with method '$method'\n" .
                    "try one of:\n" . join '', map {"\tuse $_ ();\n"} @modules;
                return ($hint, @modules);
            }
        }
    }
}

# what methods are contained in the passed module name
sub lookup_module {
    my ($module) = shift;

    unless (defined $module) {
        my $hint = "no 'module' argument was passed\n";
        return ($hint);
    }

    _get_modules() unless $modules;

    unless (exists $modules->{$module}) {
        my $hint = "don't know anything about module '$module'\n";
        return ($hint);
    }

    my @methods;
    my $max_len = 6;
    for ( @{ $modules->{$module} } ) {
        $max_len = length $_->[0] if length $_->[0] > $max_len;
        push @methods, $_->[0];
    }

    my $format = "%-${max_len}s %s\n";
    my $banner = sprintf($format, "Method", "Invoked on object type");
    my $hint = join '',
        ("\nModule '$module' contains the following XS methods:\n\n", 
         $banner,  sep(length($banner)),
         map( { sprintf $format, $_->[0], $_->[1]||'???'}
             @{ $modules->{$module} }),
         sep(length($banner)));

    return ($hint, @methods);
}

# what methods can be invoked on the passed object (or its reference)
sub lookup_object {
    my ($object) = shift;

    unless (defined $object) {
        my $hint = "no 'object' argument was passed\n";
        return ($hint);
    }

    _get_objects() unless $objects;

    # a real object was passed?
    $object = ref $object || $object;

    unless (exists $objects->{$object}) {
        my $hint = "don't know anything about objects of type '$object'\n";
        return ($hint);
    }

    my @methods;
    my $max_len = 6;
    for ( @{ $objects->{$object} } ) {
        $max_len = length $_->[0] if length $_->[0] > $max_len;
        push @methods, $_->[0];
    }

    my $format = "%-${max_len}s %s\n";
    my $banner = sprintf($format, "Method", "Module");
    my $hint = join '',
        ("\nObjects of type '$object' can invoke the following XS methods:\n\n",
         $banner, sep(length($banner)),
         map({ sprintf $format, $_->[0], $_->[1]} @{ $objects->{$object} }),
         sep(length($banner)));

    return ($hint, @methods);

}

1;
EOF
    close $fh;
}

sub write_module_versions_file {
    my $self = shift;

    my $file = catfile "lib", "ModPerl", "DummyVersions.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 "$noedit_warning\n";

    my @modules = keys %{ $self->{XS} };
    push @modules, qw(ModPerl::MethodLookup);

    my $len = 0;
    for (@modules) {
        $len = length $_ if length $_ > $len;
    }

    require mod_perl2;
    $len += length '$::VERSION';
    for (@modules) {
        my $ver = module_version($_);
        printf $fh "package %s;\n%-${len}s = %s;\n\n",
            $_, '$'.$_."::VERSION", $ver;
    }
}

sub generate {
    my $self = shift;

    $self->prepare;

    for (qw(ModPerl::WrapXS Apache2 APR ModPerl)) {
        $self->write_makefilepl($_);
    }

    $self->write_typemap;

    for (qw(typedefs sv_convert)) {
        $self->write_typemap_h_file($_);
    }

    $self->get_functions;
    $self->get_structures;
    $self->write_export_file('exp') if Apache2::Build::AIX;
    $self->write_export_file('def') if Apache2::Build::WIN32;

    while (my ($module, $functions) = each %{ $self->{XS} }) {
#        my ($root, $sub) = split '::', $module;
#        if (-e "$self->{XS_DIR}/$root/$sub/$sub.xs") {
#            $module = join '::', $root, "Wrap$sub";
#        }
        $self->write_makefilepl($module);
        $self->write_xs($module, $functions);
        $self->write_pm($module);
    }

    $self->write_lookup_method_file;
    $self->write_module_versions_file;
}

#three .sym files are generated:
#global   - global symbols
#ithreads - #ifdef USE_ITHREADS functions
#inline   - __inline__ functions
#the inline symbols are needed #ifdef MP_DEBUG
#since __inline__ will be turned off

my %multi_export = map { $_, 1 } qw(exp);

sub open_export_files {
    my ($self, $name, $ext) = @_;

    my $dir = $self->{XS_DIR};
    my %handles;
    my @types = qw(global inline ithreads);

    if ($multi_export{$ext}) {
        #write to multiple files
        for my $type (@types) {
            my $file = "$dir/${name}_$type.$ext";

            open my $fh, '>', $file or
              die "open $file: $!";

            $handles{$type} = $fh;
        }
    }
    else {
        #write to one file
        my $file = "$dir/$name.$ext";

        open my $fh, '>', $file or
          die "open $file: $!";

        for my $type (@types) {
            $handles{$type} = $fh;
        }
    }

    \%handles;
}

sub func_is_static {
    my ($self, $entry) = @_;
    if (my $attr = $entry->{attr}) {
        return 1 if grep { $_ eq 'static' } @$attr;
    }
    
    #C::Scan doesnt always pickup static __inline__
    return 1 if $entry->{name} =~ /^mpxs_/o;
    
    return 0;
}

sub func_is_inline {
    my ($self, $entry) = @_;
    if (my $attr = $entry->{attr}) {
        return 1 if grep { $_ eq '__inline__' } @$attr;
    }
    return 0;
}

sub export_file_header_exp {
    my $self = shift;
    "#!\n";
}

sub export_file_format_exp {
    my ($self, $val) = @_;
    "$val\n";
}

sub export_file_header_def {
    my $self = shift;
    "LIBRARY\n\nEXPORTS\n\n";
}

sub export_file_format_def {
    my ($self, $val) = @_;
    "   $val\n";
}

my $ithreads_exports = join '|', qw{
modperl_cmd_interp_
modperl_interp_
modperl_list_
modperl_tipool_
modperl_svptr_table_clone$
modperl_mgv_require_module$
};

sub export_func_handle {
    my ($self, $entry, $handles) = @_;

    if ($self->func_is_inline($entry)) {
        return $handles->{inline};
    }
    elsif ($entry->{name} =~ /^($ithreads_exports)/) {
        return $handles->{ithreads};
    }

    $handles->{global};
}

sub write_export_file {
    my ($self, $ext) = @_;

    my %files = (
        modperl => $ModPerl::FunctionTable,
        apache2 => $Apache2::FunctionTable,
        apr     => $APR::FunctionTable,
    );

    my $header = \&{"export_file_header_$ext"};
    my $format = \&{"export_file_format_$ext"};

    while (my ($key, $table) = each %files) {
        my $handles = $self->open_export_files($key, $ext);

	my %seen; #only write header once if this is a single file
        for my $fh (values %$handles) {
            next if $seen{$fh}++;
            print $fh $self->$header();
        }

        # add the symbols which aren't the function table
        if ($key eq 'modperl') {
            my $fh = $handles->{global};
            for my $name (@global_structs) {
                print $fh $self->$format($name);
            }
        }

        for my $entry (@$table) {
            next if $self->func_is_static($entry);
            my $name = $entry->{name};

            my $fh = $self->export_func_handle($entry, $handles);

            print $fh $self->$format($name);
        }

        %seen = (); #only close handle once if this is a single file
        for my $fh (values %$handles) {
            next if $seen{$fh}++;
            close $fh;
        }
    }
}

sub stats {
    my $self = shift;

    $self->get_functions;
    $self->get_structures;

    my %stats;

    while (my ($module, $functions) = each %{ $self->{XS} }) {
        $stats{$module} += @$functions;
        if (my $newxs = $self->{newXS}->{$module}) {
            $stats{$module} += @$newxs;
        }
    }

    return \%stats;
}

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

    if (!$build->should_build_apache) {
        print $fh <<"EOF";
/* This is intentionnaly left blank, only usefull for static build */
const void *modperl_ugly_hack = NULL;
EOF
        return;
    }
    
    print $fh <<"EOF";
/* 
 * This is indeed a ugly hack!
 * See also src/modules/perl/mod_perl.c for modperl_ugly_hack
 * If we don't build such a list of exported API functions, the over-zealous
 * linker can and will remove the unused functions completely. In order to
 * avoid this, we create this object and modperl_ugly_hack to create a 
 * dependency between all the exported API and mod_perl.c
 */
const void *modperl_ugly_hack = NULL;
EOF

    for my $entry (@$ModPerl::FunctionTable) {
        next if $self->func_is_static($entry);
        unless (Apache2::Build::PERL_HAS_ITHREADS) {
            next if $entry->{name} =~ /^($ithreads_exports)/;
        }
        ( my $name ) = $entry->{name} =~ /^modperl_(.*)/;
        print $fh <<"EOF";
#ifndef modperl_$name
const void *modperl_hack_$name = (const void *)modperl_$name;
#endif

EOF
    }
}

1;
__END__