parsesource.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 Apache2::ParseSource;

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

use Apache2::Build ();
use Config;
use File::Basename;
use File::Spec::Functions qw(catdir);

our $VERSION = '0.02';

sub new {
    my $class = shift;

    my $self = bless {
        config => Apache2::Build->build_config,
        @_,
    }, $class;

    my $prefixes = join '|', @{ $self->{prefixes} || [qw(ap_ apr_)] };
    $self->{prefix_re} = qr{^($prefixes)};

    $Apache2::Build::APXS ||= $self->{apxs};

    $self;
}

sub config {
    shift->{config};
}

sub parse {
    my $self = shift;

    $self->{scan_filename} = $self->generate_cscan_file;

    $self->{c} = $self->scan;
}

sub DESTROY {
    my $self = shift;
    unlink $self->{scan_filename}
}

{
    package Apache2::ParseSource::Scan;

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

    sub get {
        local $SIG{__DIE__} = \&Carp::confess;
        shift->SUPER::get(@_);
    }
}

my @c_scan_defines = (
    'CORE_PRIVATE',   #so we get all of apache
    'MP_SOURCE_SCAN', #so we can avoid some c-scan barfing
    '_NETINET_TCP_H', #c-scan chokes on netinet/tcp.h
 #   'APR_OPTIONAL_H', #c-scan chokes on apr_optional.h
    'apr_table_do_callback_fn_t=void', #c-scan chokes on function pointers
);


# some types c-scan failing to resolve
push @c_scan_defines, map { "$_=void" } 
    qw(PPADDR_t PerlExitListEntry modperl_tipool_vtbl_t);

sub scan {
    require ModPerl::CScan;
    ModPerl::CScan->VERSION(0.75);
    require Carp;

    my $self = shift;

    my $c = ModPerl::CScan->new(filename => $self->{scan_filename});

    my $includes = $self->includes;

    # where to find perl headers, but we don't want to parse them otherwise
    my $perl_core_path = catdir $Config{installarchlib}, "CORE";
    push @$includes, $perl_core_path;

    $c->set(includeDirs => $includes);

    my @defines = @c_scan_defines;

    unless ($Config{useithreads} and $Config{useithreads} eq 'define') {
        #fake -DITHREADS so function tables are the same for
        #vanilla and ithread perls, that is,
        #make sure THX and friends are always expanded
        push @defines, 'MP_SOURCE_SCAN_NEED_ITHREADS';
    }

    $c->set(Defines => join ' ', map "-D$_", @defines);

    bless $c, 'Apache2::ParseSource::Scan';
}

sub include_dirs {
    my $self = shift;
    ($self->config->apxs('-q' => 'INCLUDEDIR'),
     $self->config->mp_include_dir);
}

sub includes { shift->config->includes }

sub find_includes {
    my $self = shift;

    return $self->{includes} if $self->{includes};

    require File::Find;

    my @includes = ();
    # don't pick preinstalled mod_perl headers if any, but pick the rest
    {
        my @dirs = $self->include_dirs;
        die "could not find include directory (build the project first)"
            unless -d $dirs[0];

        my $unwanted = join '|', qw(ap_listen internal version
                                    apr_optional mod_include mod_cgi
                                    mod_proxy mod_ssl ssl_ apr_anylock
                                    apr_rmm ap_config mod_log_config
                                    mod_perl modperl_ apreq);
        $unwanted = qr|^$unwanted|;
        my $wanted = '';

        push @includes, find_includes_wanted($wanted, $unwanted, @dirs);
    }

    # now add the live mod_perl headers (to make sure that we always
    # work against the latest source)
    {
        my @dirs = map { catdir $self->config->{cwd}, $_ }
            catdir(qw(src modules perl)), 'xs';

        my $unwanted = '';
        my $wanted = join '|', qw(mod_perl modperl_);
        $wanted = qr|^$wanted|;

        push @includes, find_includes_wanted($wanted, $unwanted, @dirs);
    }

    # now reorg the header files list, so the fragile scan won't choke
    my @apr = ();
    my @mp = ();
    my @rest = ();
    for (@includes) {
        if (/mod_perl.h$/) {
            # mod_perl.h needs to be included before other mod_perl
            # headers
            unshift @mp, $_;
        }
        elsif (/modperl_\w+.h$/) {
            push @mp, $_;
        }
        elsif (/apr_\w+\.h$/ ) {
            # apr headers need to be included first
            push @apr, $_;
        }
        else {
            push @rest, $_;
        }
    }
    @includes = (@apr, @rest, @mp);

    return $self->{includes} = \@includes;
}

sub find_includes_wanted {
    my ($wanted, $unwanted, @dirs) = @_;
    my @includes = ();
    for my $dir (@dirs) {
        File::Find::finddepth({
                               wanted => sub {
                                   return unless /\.h$/;

                                   if ($wanted) {
                                       return unless /$wanted/;
                                   }
                                   else {
                                       return if /$unwanted/;
                                   }

                                   my $dir = $File::Find::dir;
                                   push @includes, "$dir/$_";
                               },
                               (Apache2::Build::WIN32 ? '' : follow => 1),
                              }, $dir);
    }
    return @includes;
}

sub generate_cscan_file {
    my $self = shift;

    my $includes = $self->find_includes;

    my $filename = '.apache_includes';
    open my $fh, '>', $filename or die "can't open $filename: $!";

    for my $path (@$includes) {
        my $filename = basename $path;
        print $fh qq(\#include "$path"\n);
    }

    close $fh;

    return $filename;
}

my %defines_wanted = (
    'Apache2::Const' => {
        common     => [qw{OK DECLINED DONE}],
        config     => [qw{DECLINE_CMD}],
        context    => [qw(NOT_IN_ GLOBAL_ONLY)],
        http       => [qw{HTTP_}],
        log        => [qw(APLOG_)],
        methods    => [qw{M_ METHODS}],
        mpmq       => [qw{AP_MPMQ_}],
        options    => [qw{OPT_}],
        override   => [qw{OR_ EXEC_ON_READ ACCESS_CONF RSRC_CONF}],
        platform   => [qw{CRLF CR LF}],
        remotehost => [qw{REMOTE_}],
        satisfy    => [qw{SATISFY_}],
        types      => [qw{DIR_MAGIC_TYPE}],
    },
    'APR::Const' => {
        common    => [qw{APR_SUCCESS}],
        error     => [qw{APR_E}],
        filepath  => [qw{APR_FILEPATH_}],
        filetype  => [qw{APR_FILETYPE_}],
        fopen     => [qw{APR_FOPEN_}],
        fprot     => [qw{APR_FPROT_}],
        finfo     => [qw{APR_FINFO_}],
        flock     => [qw{APR_FLOCK_}],
        hook      => [qw{APR_HOOK_}],
        limit     => [qw{APR_LIMIT}],
        poll      => [qw{APR_POLL}],
        socket    => [qw{APR_SO_}],
        status    => [qw{APR_TIMEUP}],
        table     => [qw{APR_OVERLAP_TABLES_}],
        uri       => [qw{APR_URI_}],
    },
   ModPerl => {
        common    => [qw{MODPERL_RC_}],
   }
);

my %defines_wanted_re;
while (my ($class, $groups) = each %defines_wanted) {
    while (my ($group, $wanted) = each %$groups) {
        my $pat = join '|', @$wanted;
        $defines_wanted_re{$class}->{$group} = $pat; #qr{^($pat)};
    }
}

my %enums_wanted = (
    'Apache2::Const' => { map { $_, 1 } qw(cmd_how input_mode filter_type conn_keepalive) },
    'APR::Const' => { map { $_, 1 } qw(apr_shutdown_how apr_read_type apr_lockmech) },
);

my $defines_unwanted = join '|', qw{
HTTP_VERSION APR_EOL_STR APLOG_MARK APLOG_NOERRNO APR_SO_TIMEOUT
};

sub get_constants {
    my ($self) = @_;

    my $includes = $self->find_includes;
    my (%constants, %seen);

    for my $file (@$includes) {
        open my $fh, $file or die "open $file: $!";
        while (<$fh>) {
            if (s/^\#define\s+(\w+)\s+.*/$1/) {
                chomp;
                next if /_H$/;
                next if $seen{$_}++;
                $self->handle_constant(\%constants);
            }
            elsif (m/enum[^\{]+\{/) {
                $self->handle_enum($fh, \%constants);
            }
        }
        close $fh;
    }

    #maintain a few handy shortcuts from 1.xx
    #aliases are defined in ModPerl::Code
    push @{ $constants{'Apache2::Const'}->{common} },
      qw(NOT_FOUND FORBIDDEN AUTH_REQUIRED SERVER_ERROR REDIRECT);