typemap.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::TypeMap;

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

use ModPerl::FunctionMap ();
use ModPerl::StructureMap ();
use ModPerl::MapUtil qw(list_first);

our @ISA = qw(ModPerl::MapBase);

sub new {
    my $class = shift;

    my $self = bless {
        INCLUDE => [],
        struct  => [],
        typedef => [],
    }, $class;

    $self->{function_map}  = ModPerl::FunctionMap->new,
    $self->{structure_map} = ModPerl::StructureMap->new,

    $self->get;
    $self;
}

my %special = map { $_, 1 } qw(UNDEFINED NOTIMPL CALLBACK);

sub special {
    my ($self, $class) = @_;
    return $special{$class};
}

sub function_map  { shift->{function_map}->get  }
sub structure_map { shift->{structure_map}->get }

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

    while ($fh->readline) {
        if (/E=/) {
            my %args = $self->parse_keywords($_);
            while (my ($key,$val) = each %args) {
                push @{ $self->{$key} }, $val;
            }
            next;
        }

        my @aliases;
        my ($type, $class) = (split /\s*\|\s*/, $_)[0,1];
        $class ||= 'UNDEFINED';

        if ($type =~ s/^(struct|typedef)\s+(.*)/$2/) {
            my $typemap = $1;
            push @aliases, $type;

            if ($typemap eq 'struct') {
                push @aliases, "const $type", "$type *", "const $type *",
                  "struct $type *", "const struct $type *",
                  "$type **";
            }

            my $cname = $class;
            if ($cname =~ s/::/__/g) {
                push @{ $self->{$typemap} }, [$type, $cname];
            }
        }
        elsif ($type =~ /_t$/) {
            push @aliases, $type, "$type *", "const $type *";
        }
        else {
            push @aliases, $type;
        }

        for (@aliases) {
            $map->{$_} = $class;
        }
    }
}

sub get {
    my $self = shift;

    $self->{map} ||= $self->parse_map_files;
}

my $ignore = join '|', qw{
ap_LINK ap_HOOK _ UINT union._
union.block_hdr cleanup process_chain
iovec struct.rlimit Sigfunc in_addr_t
};

sub should_ignore {
    my ($self, $type) = @_;
    return 1 if $type =~ /^($ignore)/o;
}

sub is_callback {
    my ($self, $type) = @_;
    return 1 if $type =~ /\(/ and $type =~ /\)/; #XXX: callback
}

sub exists {
    my ($self, $type) = @_;

    return 1 if $self->is_callback($type) || $self->should_ignore($type);

    $type =~ s/\[\d+\]$//; #char foo[64]

    return exists $self->get->{$type};
}

sub map_type {
    my ($self, $type) = @_;
    my $class = $self->get->{$type};

    return unless $class and ! $self->special($class);
#    return if $type =~ /\*\*$/; #XXX
    if ($class =~ /::/) {
        return $class;
    }
    else {
        return $type;
    }
}

sub null_type {
    my ($self, $type) = @_;
    my $class = $self->get->{$type};

    if ($class =~ /^[INU]V/) {
        return '0';
    }
    else {
        return 'NULL';
    }
}

sub can_map {
    my $self = shift;
    my $map = shift;

    return 1 if $map->{argspec};

    for (@_) {
        return (0, $_) unless $self->map_type($_);
    }

    return 1;
}

sub map_arg {
    my ($self, $arg) = @_;

    my $map_type = $self->map_type($arg->{type});
    die "unknown typemap: '$arg->{type}'" unless defined $map_type;

    return {
       name    => $arg->{name},
       default => $arg->{default},
       type    => $map_type,
       rtype   => $arg->{type},
    }
}

sub map_args {
    my ($self, $func) = @_;

    my $entry = $self->function_map->{ $func->{name} };
    my $argspec = $entry->{argspec};
    my $args = [];

    if ($argspec) {
        $entry->{orig_args} = [ map $_->{name}, @{ $func->{args} } ];

        for my $arg (@$argspec) {
            my $default;
            ($arg, $default) = split /=/, $arg, 2;
            my ($type, $name) = split ':', $arg, 2;

            if ($type and $name) {
                push @$args, {
                   name => $name,
                   type => $type,
                   default => $default,
                };
            }
            else {
                my $e = list_first { $_->{name} eq $arg } @{ $func->{args} };
                if ($e) {
                    push @$args, { %$e, default => $default };
                }
                elsif ($arg eq '...') {
                    push @$args, { name => '...', type => 'SV *' };
                }
                else {
                    warn "bad argspec: $func->{name} ($arg)\n";
                }
            }
        }
    }
    else {
        $args = $func->{args};
    }

    return [ map $self->map_arg($_), @$args ]
}

#this is needed for modperl-only functions
#unlike apache/apr functions which are remapped to a mpxs_ function
sub thx_fixup {
    my ($self, $func) = @_;

    my $first = $func->{args}->[0];

    return unless $first;

    if ($first->{type} =~ /PerlInterpreter/) {
        shift @{ $func->{args} };
        $func->{thx} = 1;
    }
}

sub map_function {
    my ($self, $func) = @_;

    my $map = $self->function_map->{ $func->{name} };
    return unless $map;

    $self->thx_fixup($func);

    my ($status, $failed_type) = 
        $self->can_map($map, $func->{return_type},
            map $_->{type}, @{ $func->{args} });

    unless ($status) {
        warn "unknown typemap: '$failed_type' (skipping $func->{name})\n";
        return;
    }

    my $type = $map->{return_type} || $func->{return_type} || 'void';
    my $map_type = $self->map_type($type);
    die "unknown typemap: '$type'" unless defined $map_type;

    my $mf = {
       name        => $func->{name},
       return_type => $map_type,
       args        => $self->map_args($func),
       perl_name   => $map->{name},
       thx         => $func->{thx},
    };

    for (qw(dispatch argspec orig_args prefix)) {
        $mf->{$_} = $map->{$_};
    }

    unless ($mf->{class}) {
        $mf->{class} = $map->{class} || $self->first_class($mf);
        #print "GUESS class=$mf->{class} for $mf->{name}\n";
    }

    $mf->{prefix} ||= ModPerl::FunctionMap::guess_prefix($mf);

    $mf->{module} = $map->{module} || $mf->{class};

    $mf;
}

sub map_structure {
    my ($self, $struct) = @_;

    my ($class, @elts);
    my $stype = $struct->{type};

    return unless $class = $self->map_type($stype);

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

        # ro/rw/r+w_startup/undef(disabled)
        my $access_mode = $self->structure_map->{$stype}->{$name};
        next unless $access_mode;
        next unless $rtype = $self->map_type($type);

        push @elts, {
           name        => $name,
           type        => $rtype,
           default     => $self->null_type($type),
           pool        => $self->class_pool($class),
           class       => $self->{map}->{$type} || "",
           access_mode => $access_mode,
        };
    }

    return {
       module => $self->{structure_map}->{MODULES}->{$stype} || $class,
       class  => $class,
       type   => $stype,
       elts   => \@elts,
    };
}

sub destructor {
    my ($self, $prefix) = @_;
    $self->function_map->{$prefix . 'DESTROY'};
}

sub first_class {
    my ($self, $func) = @_;

    for my $e (@{ $func->{args} }) {
        next unless $e->{type} =~ /::/;
        #there are alot of util functions that take an APR::Pool
        #that do not belong in the APR::Pool class
        next if $e->{type} eq 'APR::Pool' and $func->{name} !~ /^apr_pool/;
        return $e->{type};
    }

    return $func->{name} =~ /^apr_/ ? 'APR' : 'Apache2';
}

sub check {
    my $self = shift;

    my (@types, @missing, %seen);

    require Apache2::StructureTable;
    for my $entry (@$Apache2::StructureTable) {
        push @types, map $_->{type}, @{ $entry->{elts} };
    }

    for my $entry (@$Apache2::FunctionTable) {
        push @types, grep { not $seen{$_}++ }
          ($entry->{return_type},
           map $_->{type}, @{ $entry->{args} })
    }

    #printf "%d types\n", scalar @types;

    for my $type (@types) {
        push @missing, $type unless $self->exists($type);
    }

    return @missing ? \@missing : undef;
}

#look for Apache/APR structures that do not exist in structure.map
my %ignore_check = map { $_,1 } qw{
module_struct cmd_how kill_conditions
regex_t regmatch_t pthread_mutex_t
unsigned void va_list ... iovec char int long const
gid_t uid_t time_t pid_t size_t
sockaddr hostent
SV
};

sub check_exists {
    my $self = shift;

    my %structures = map { $_->{type}, 1 } @{ $self->structure_table() };
    my @missing = ();
    my %seen;

    for my $name (keys %{ $self->{map} }) {
        1 while $name =~ s/^\w+\s+(\w+)/$1/;
        $name =~ s/\s+\**.*$//;
        next if $seen{$name}++ or $structures{$name} or $ignore_check{$name};
        push @missing, $name;
    }

    return @missing ? \@missing : undef;
}

#XXX: generate this
my %class_pools = map {
    (my $f = "mpxs_${_}_pool") =~ s/:/_/g;
    $_, $f;
} qw{
     Apache2::RequestRec Apache2::Connection Apache2::URI APR::URI
};

sub class_pool : lvalue {
    my ($self, $class) = @_;
    $class_pools{$class};
}

#anything needed that mod_perl.h does not already include
#XXX: .maps should INCLUDE= these
my @includes = qw{
apr_uuid.h
apr_sha1.h
apr_md5.h
apr_base64.h
apr_getopt.h
apr_hash.h
apr_lib.h
apr_general.h
apr_signal.h
util_script.h
};

sub h_wrap {
    my ($self, $file, $code) = @_;

    $file = 'modperl_xs_' . $file;

    my $h_def = uc "${file}_h";
    my $preamble = "\#ifndef $h_def\n\#define $h_def\n\n";
    my $postamble = "\n\#endif /* $h_def */\n";

    return ("$file.h", $preamble . $code . $postamble);
}

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

    my $file = 'modperl_xs_typedefs';
    my $h_def = uc "${file}_h";
    my $code = "";

    for (@includes, @{ $self->{INCLUDE} }) {
        $code .= qq{\#include "$_"\n}
    }

    for my $t (@{ $self->{struct} }) {
        next if $seen{ $t->[1] }++;
        $code .= "typedef $t->[0] * $t->[1];\n";
    }

    for my $t (@{ $self->{typedef} }) {
        next if $seen{ $t->[1] }++;
        $code .= "typedef $t->[0] $t->[1];\n";
    }

    $self->h_wrap('typedefs', $code);
}

my %convert_alias = (
    Apache2__RequestRec => 'r',
    Apache2__Server => 'server',
    Apache2__Connection => 'connection',
    APR__Table => 'table',
    APR__UUID => 'uuid',
    apr_status_t => 'status',
);

sub sv_convert_code {
    my $self = shift;
    my $map = $self->get;
    my %seen;
    my $code = "";

    while (my ($ctype, $ptype) = each %$map) {
        next if $self->special($ptype);
        next if $ctype =~ /\s/;
        my $class = $ptype;

        if ($ptype =~ s/:/_/g) {
            next if $seen{$ptype}++;

            my $alias;
            my $expect = "expecting an $class derived object";
            my $croak  = "argument is not a blessed reference";

            #Perl -> C
            my $define = "mp_xs_sv2_$ptype";

            $code .= <<EOF;
#define $define(sv) \\
((SvROK(sv) && (SvTYPE(SvRV(sv)) == SVt_PVMG)) \\
|| (Perl_croak(aTHX_ "$croak ($expect)"),0) ? \\
INT2PTR($ctype *, SvIV((SV*)SvRV(sv))) : ($ctype *)NULL)

EOF

            if ($alias = $convert_alias{$ptype}) {
                $code .= "#define mp_xs_sv2_$alias $define\n\n";
            }

            #C -> Perl
            $define = "mp_xs_${ptype}_2obj";

            $code .= <<EOF;
#define $define(ptr) \\
sv_setref_pv(sv_newmortal(), "$class", (void*)ptr)

EOF

            if ($alias) {
                $code .= "#define mp_xs_${alias}_2obj $define\n\n";
            }
        }
        else {
            if ($ptype =~ /^(\wV)$/) {
                my $class = $1;
                my $define = "mp_xs_sv2_$ctype";

                $code .= "#define $define(sv) ($ctype)Sv$class(sv)\n\n";

                if (my $alias = $convert_alias{$ctype}) {
                    $code .= "#define mp_xs_sv2_$alias $define\n\n";
                }
            }
        }
    }

    $self->h_wrap('sv_convert', $code);
}

1;
__END__