code.pm

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

# Copyright 2000-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::Code;

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

use Config;
use File::Spec::Functions qw(catfile catdir);

use mod_perl2 ();
use Apache2::Build ();

use Apache::TestConfig ();
use Apache::TestTrace;

our $VERSION = '0.01';
our @ISA = qw(Apache2::Build);

my %handlers = (
    Process    => [qw(ChildInit ChildExit)], #Restart PreConfig
    Files      => [qw(OpenLogs PostConfig)],
    PerSrv     => [qw(PostReadRequest Trans MapToStorage)],
    PerDir     => [qw(HeaderParser
                      Access Authen Authz
                      Type Fixup Response Log Cleanup
                      InputFilter OutputFilter)],
    Connection => [qw(ProcessConnection)],
    PreConnection => [qw(PreConnection)],
);

my %hooks = map { $_, canon_lc($_) }
    map { @{ $handlers{$_} } } keys %handlers;

my %not_ap_hook = map { $_, 1 } qw(child_exit response cleanup
                                   output_filter input_filter);

my %not_request_hook = map { $_, 1 } qw(child_init process_connection
                                        pre_connection open_logs post_config);

my %hook_proto = (
    Process    => {
        ret  => 'void',
        args => [{type => 'apr_pool_t', name => 'p'},
                 {type => 'server_rec', name => 's'},
                 {type => 'dummy', name => 'MP_HOOK_VOID'}],
    },
    Files      => {
        ret  => 'int',
        args => [{type => 'apr_pool_t', name => 'pconf'},
                 {type => 'apr_pool_t', name => 'plog'},
                 {type => 'apr_pool_t', name => 'ptemp'},
                 {type => 'server_rec', name => 's'},
                 {type => 'dummy', name => 'MP_HOOK_RUN_ALL'}],
    },
    PerSrv     => {
        ret  => 'int',
        args => [{type => 'request_rec', name => 'r'}, 
                 {type => 'dummy', name => 'MP_HOOK_RUN_ALL'}],
    },
    Connection => {
        ret  => 'int',
        args => [{type => 'conn_rec', name => 'c'},
                 {type => 'dummy', name => 'MP_HOOK_RUN_FIRST'}],
    },
    PreConnection => {
        ret  => 'int',
        args => [{type => 'conn_rec', name => 'c'},
                 {type => 'void', name => 'csd'},
                 {type => 'dummy', name => 'MP_HOOK_RUN_ALL'}],
    },
);

my %cmd_push = (
    InputFilter  => 'modperl_cmd_push_filter_handlers',
    OutputFilter => 'modperl_cmd_push_filter_handlers',
);
my $cmd_push_default = 'modperl_cmd_push_handlers';
sub cmd_push {
    $cmd_push{+shift} || $cmd_push_default;
}

$hook_proto{PerDir} = $hook_proto{PerSrv};

my $scfg_get = 'MP_dSCFG(parms->server)';

my $dcfg_get = "$scfg_get;\n" .
  '    modperl_config_dir_t *dcfg = (modperl_config_dir_t *)dummy';

my %directive_proto = (
    PerSrv     => {
        args => [{type => 'cmd_parms', name => 'parms'},
                 {type => 'void', name => 'dummy'},
                 {type => 'const char', name => 'arg'}],
        cfg  => {get => $scfg_get, name => 'scfg'},
        scope => 'RSRC_CONF',
    },
    PerDir     => {
        args => [{type => 'cmd_parms', name => 'parms'},
                 {type => 'void', name => 'dummy'},
                 {type => 'const char', name => 'arg'}],
        cfg  => {get => $dcfg_get, name => 'dcfg'},
        scope => 'OR_ALL',
    },
);

for my $class (qw(Process Connection PreConnection Files)) {
    $directive_proto{$class}->{cfg}->{name} = 'scfg';
    $directive_proto{$class}->{cfg}->{get} = $scfg_get;

    for (qw(args scope)) {
        $directive_proto{$class}->{$_} = $directive_proto{PerSrv}->{$_};
    }
}

while (my ($k,$v) = each %directive_proto) {
    $directive_proto{$k}->{ret} = 'const char *';
    my $handlers = join '_', 'handlers', canon_lc($k);
    $directive_proto{$k}->{handlers} =
      join '->', $directive_proto{$k}->{cfg}->{name}, $handlers;
}

#XXX: allow disabling of PerDir hooks on a PerDir basis
my @hook_flags = (map { canon_uc($_) } keys %hooks);
my @ithread_opts = qw(CLONE PARENT);
my %flags = (
    Srv => ['NONE', @ithread_opts, qw(ENABLE AUTOLOAD MERGE_HANDLERS),
            @hook_flags, 'UNSET'],
    Dir => [qw(NONE PARSE_HEADERS SETUP_ENV MERGE_HANDLERS GLOBAL_REQUEST UNSET)],
    Req => [qw(NONE SET_GLOBAL_REQUEST PARSE_HEADERS SETUP_ENV 
               CLEANUP_REGISTERED PERL_SET_ENV_DIR PERL_SET_ENV_SRV)],
    Interp => [qw(NONE IN_USE PUTBACK CLONED BASE)],
    Handler => [qw(NONE PARSED METHOD OBJECT ANON AUTOLOAD DYNAMIC FAKE)],
);

$flags{DirSeen} = $flags{Dir};

my %flags_options = map { $_,1 } qw(Srv Dir);

my %flags_field = (
    DirSeen => 'flags->opts_seen',
    (map { $_, 'flags->opts' } keys %flags_options),
);

sub new {
    my $class = shift;
    bless {
       handlers        => \%handlers,
       hook_proto      => \%hook_proto,
       directive_proto => \%directive_proto,
       flags           => \%flags,
       path            => 'src/modules/perl',
    }, $class;
}

sub path { shift->{path} }

sub handler_desc {
    my ($self, $h_add, $c_add) = @_;
    local $" = ",\n";
    while (my ($class, $h) = each %{ $self->{handler_index_desc} }) {
        my $func = canon_func('handler', 'desc', $class);
        my $array = join '_', 'MP', $func;
        my $proto = "const char *$func(int idx)";

        $$h_add .= "$proto;\n";

        $$c_add .= <<EOF;
static const char * $array [] = {
@{ [ map { $_ ? qq(    "$_") : '    NULL' } @$h, '' ] }
};

$proto
{
    return $array [idx];
}

EOF
    }
}

sub generate_handler_index {
    my ($self, $h_fh) = @_;

    my $type = 1;

    while (my ($class, $handlers) = each %{ $self->{handlers} }) {
        my $i = 0;
        my $n = @$handlers;
        my $handler_type = canon_define('HANDLER_TYPE', $class);

        print $h_fh "\n#define ",
          canon_define('HANDLER_NUM', $class), " $n\n\n";

        print $h_fh "#define $handler_type $type\n\n";

        $type++;

        for my $name (@$handlers) {
            my $define = canon_define($name, 'handler');
            $self->{handler_index}->{$class}->[$i] = $define;
            $self->{handler_index_type}->{$class}->[$i] = $handler_type;
            $self->{handler_index_desc}->{$class}->[$i] = "Perl${name}Handler";
            print $h_fh "#define $define $i\n";
            $i++;
        }
    }
}

sub generate_handler_hooks {
    my ($self, $h_fh, $c_fh) = @_;

    my @register_hooks;

    while (my ($class, $prototype) = each %{ $self->{hook_proto} }) {
        my $callback = canon_func('callback', $class);
        my $return = $prototype->{ret} eq 'void' ? '' : 'return';
        my $i = -1;

        for my $handler (@{ $self->{handlers}{$class} }) {
            my $name = canon_func($handler, 'handler');
            $i++;

            if (my $hook = $hooks{$handler}) {
                next if $not_ap_hook{$hook};

                my $order = $not_request_hook{$hook} ? 'APR_HOOK_FIRST'
                                                     : 'APR_HOOK_REALLY_FIRST';

                push @register_hooks,
                  "    ap_hook_$hook($name, NULL, NULL, $order);";
            }

            my ($protostr, $pass) = canon_proto($prototype, $name);
            my $ix = $self->{handler_index}->{$class}->[$i];

            if ($callback =~ m/modperl_callback_per_(dir|srv)/) {
                if ($ix =~ m/AUTH|TYPE|TRANS|MAP/) {
                    $pass =~ s/MP_HOOK_RUN_ALL/MP_HOOK_RUN_FIRST/;
                }
            }

            print $h_fh "\n$protostr;\n";

            print $c_fh <<EOF;
$protostr
{
    $return $callback($ix, $pass);
}

EOF
        }
    }

    local $" = "\n";
    my $hooks_proto = 'void modperl_register_handler_hooks(void)';
    my $h_add = "$hooks_proto;\n";
    my $c_add = "$hooks_proto {\n@register_hooks\n}\n";

    $self->handler_desc(\$h_add, \$c_add);

    return ($h_add, $c_add);
}

sub generate_handler_find {
    my ($self, $h_fh, $c_fh) = @_;

    my $proto = 'int modperl_handler_lookup(const char *name, int *type)';
    my (%ix, %switch);

    print $h_fh "$proto;\n";

    print $c_fh <<EOF;
$proto
{
    if (*name == 'P' && strnEQ(name, "Perl", 4)) {
        name += 4;
    }

    switch (*name) {
EOF

    while (my ($class, $handlers) = each %{ $self->{handlers} }) {
        my $i = 0;

        for my $name (@$handlers) {
            $name =~ /^([A-Z])/;
            push @{ $switch{$1} }, $name;
            $ix{$name}->{name} = $self->{handler_index}->{$class}->[$i];
            $ix{$name}->{type} = $self->{handler_index_type}->{$class}->[$i++];
        }
    }

    for my $key (sort keys %switch) {
        my $names = $switch{$key};
        print $c_fh "      case '$key':\n";

        #support $r->push_handlers(PerlHandler => ...)
        if ($key eq 'H') {
            print $c_fh <<EOF;
          if (strEQ(name, "Handler")) {
              *type = $ix{'Response'}->{type};
              return $ix{'Response'}->{name};
          }
EOF
        }

        for my $name (@$names) {
            my $n = length($name);
            print $c_fh <<EOF;
          if (strnEQ(name, "$name", $n)) {
              *type = $ix{$name}->{type};
              return $ix{$name}->{name};
          }
EOF
        }
    }

    print $c_fh "    };\n    return -1;\n}\n";

    return ("", "");
}

sub generate_handler_directives {
    my ($self, $h_fh, $c_fh) = @_;

    my @cmd_entries;

    while (my ($class, $handlers) = each %{ $self->{handlers} }) {
        my $prototype = $self->{directive_proto}->{$class};
        my $i = 0;

        for my $h (@$handlers) {
            my $h_name = join $h, qw(Perl Handler);
            my $name = canon_func('cmd', $h, 'handlers');
            my $cmd_name = canon_define('cmd', $h, 'entry');
            my $protostr = canon_proto($prototype, $name);
            my $flag = 'MpSrv' . canon_uc($h);
            my $ix = $self->{handler_index}->{$class}->[$i++];
            my $av = "$prototype->{handlers} [$ix]";
            my $cmd_push = cmd_push($h);

            print $h_fh "$protostr;\n";

            push @cmd_entries, $cmd_name;

            print $h_fh <<EOF;

#define $cmd_name \\
AP_INIT_ITERATE("$h_name", $name, NULL, \\
 $prototype->{scope}, "Subroutine name")

EOF
            print $c_fh <<EOF;

$protostr
{
    $prototype->{cfg}->{get};
    if (!MpSrvENABLE(scfg)) {
        return apr_pstrcat(parms->pool,
                           "Perl is disabled for server ",
                           parms->server->server_hostname, NULL);
    }
    if (!$flag(scfg)) {
        return apr_pstrcat(parms->pool,
                           "$h_name is disabled for server ",
                           parms->server->server_hostname, NULL);
    }
    MP_TRACE_d(MP_FUNC, "push \@%s, %s\\n", parms->cmd->name, arg);
    return $cmd_push(&($av), arg, parms->pool);
}
EOF
        }
    }

    my $h_add =  '#define MP_CMD_ENTRIES \\' . "\n" . join ', \\'."\n", @cmd_entries;

    return ($h_add, "");
}

sub generate_flags {
    my ($self, $h_fh, $c_fh) = @_;

    my $n = 1;

    (my $dlsrc = uc $Config{dlsrc}) =~ s/\.xs$//i;

    print $h_fh "\n#define MP_SYS_$dlsrc 1\n";

    while (my ($class, $opts) = each %{ $self->{flags} }) {
        my @lookup = ();
        my %lookup = ();
        my $lookup_proto = "";
        my %dumper;
        if ($flags_options{$class}) {
            $lookup_proto = join canon_func('flags', 'lookup', $class),
              'U32 ', '(const char *str)';
            push @lookup, "$lookup_proto {";
        }

        my $flags = join $class, qw(Mp FLAGS);
        my $field = $flags_field{$class} || 'flags';

        print $h_fh "\n#define $flags(p) (p)->$field\n";

        $class = "Mp$class";
        print $h_fh "\n#define ${class}Type $n\n";
        $n++;

        my $i = 0;
        my $max_len = 0;
        for my $f (@$opts) {
            my $x = sprintf "0x%08x", $i;
            my $flag = "${class}_f_$f";
            my $cmd  = $class . $f;
            my $name = canon_name($f);
            $lookup{$name} = $flag;
            $max_len = length $name if $max_len < length $name;
            print $h_fh <<EOF;

/* $f */
#define $flag $x
#define $cmd(p)  ($flags(p) & $flag)
#define ${cmd}_On(p)  ($flags(p) |= $flag)
#define ${cmd}_Off(p) ($flags(p) &= ~$flag)

EOF
            $dumper{$name} =
              qq{modperl_trace(NULL, " $name %s", \\
                         ($flags(p) & $x) ? "On " : "Off");};

            $i += $i || 1;
        }
        if (@lookup) {
            my $indent1 = " " x 4;
            my $indent2 = " " x 8;
            my %switch = ();
            for (keys %lookup) {
                if (/^(\w)/) {
                    my $gap = " " x ($max_len - length $_);
                    push @{ $switch{$1} }, 
                        qq{if (strEQ(str, "$_"))$gap return $lookup{$_};};
                }
            }

            push @lookup, '', $indent1 . "switch (*str) {";
            for (keys %switch) {
                push @lookup, $indent1 . "  case '$_':";
                push @lookup, map { $indent2 . $_ } @{ $switch{$_} };
            }
            push @lookup, map { $indent1 . $_ } ("}\n", "return 0;\n}\n\n");

            print $c_fh join "\n", @lookup;
            print $h_fh "$lookup_proto;\n";
        }

        delete $dumper{None}; #NONE
        print $h_fh join ' \\'."\n", 
          "#define ${class}_dump_flags(p, str)",
                     qq{modperl_trace(NULL, "$class flags dump (%s):", str);},
                     map $dumper{$_}, sort keys %dumper;
    }

    print $h_fh "\n#define MpSrvHOOKS_ALL_On(p) MpSrvFLAGS(p) |= (",
      (join '|', map { 'MpSrv_f_' . $_ } @hook_flags), ")\n";

    print $h_fh "\n#define MpSrvOPT_ITHREAD_ONLY(o) \\\n",
      (join ' || ', map("(o == MpSrv_f_$_)", @ithread_opts)), "\n";

    ();
}

my %trace = (
    'a' => 'Apache API interaction',
    'c' => 'configuration for directive handlers',
    'd' => 'directive processing',
    'e' => 'environment variables',
    'f' => 'filters',
    'g' => 'globals management',
    'h' => 'handlers',
    'i' => 'interpreter pool management',
    'm' => 'memory allocations',
    'o' => 'I/O',
    'r' => 'Perl runtime interaction',
    's' => 'Perl sections',
    't' => 'benchmark-ish timings',
);

sub generate_trace {
    my ($self, $h_fh) = @_;

    my $v     = $self->{build}->{VERSION};
    my $api_v = $self->{build}->{API_VERSION};

    print $h_fh qq(#define MP_VERSION_STRING "mod_perl/$v"\n);

    # this needs to be a string, not an int, because of the
    # macro definition.  patches welcome.
    print $h_fh qq(#define MP_API_VERSION "$api_v"\n);

    my $i = 1;
    my @trace = sort keys %trace;
    my $opts = join '', @trace;
    my $tl = "MP_debug_level";

    print $h_fh <<EOF;
#define MP_TRACE_OPTS "$opts"

#ifdef MP_TRACE
#define MP_TRACE_any if ($tl) modperl_trace
#define MP_TRACE_any_do(exp) if ($tl) { \\
exp; \\
}
#else
#define MP_TRACE_any if (0) modperl_trace
#define MP_TRACE_any_do(exp)
#endif

EOF

    my @dumper;
    for my $type (sort @trace) {
        my $define = "#define MP_TRACE_$type";
        my $define_do = join '_', $define, 'do';

        print $h_fh <<EOF;
#ifdef MP_TRACE
$define if ($tl & $i) modperl_trace
$define_do(exp) if ($tl & $i) { \\
exp; \\
}
#else
$define if (0) modperl_trace
$define_do(exp)
#endif
EOF
        push @dumper,
          qq{modperl_trace(NULL, " $type %s ($trace{$type})", ($tl & $i) ? "On " : "Off");};
        $i += $i;
    }

    print $h_fh join ' \\'."\n", 
                     '#define MP_TRACE_dump_flags()',
                     qq{modperl_trace(NULL, "mod_perl trace flags dump:");},
                     @dumper;

    ();
}

sub generate_largefiles {
    my ($self, $h_fh) = @_;

    my $flags = $self->perl_config('ccflags_uselargefiles');

    return unless $flags;

    for my $flag (split /\s+/, $flags) {
        next if $flag =~ /^-/; # skip -foo flags
        my ($name, $val) = split '=', $flag;
        $val ||= '';
        $name =~ s/^-D//;
        print $h_fh "#define $name $val\n";