code.pm

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

    }
}

sub ins_underscore {
    $_[0] =~ s/([a-z])([A-Z])/$1_$2/g;
    $_[0] =~ s/::/_/g;
}

sub canon_uc {
    my $s = shift;
    ins_underscore($s);
    uc $s;
}

sub canon_lc {
    my $s = shift;
    ins_underscore($s);
    lc $s;
}

sub canon_func {
    join '_', 'modperl', map { canon_lc($_) } @_;
}

sub canon_name {
    local $_ = shift;
    s/([A-Z]+)/ucfirst(lc($1))/ge;
    s/_//g;
    $_;
}

sub canon_define {
    join '_', 'MP', map { canon_uc($_) } @_;
}

sub canon_args {
    my $args = shift->{args};
    my @pass = map { $_->{name} } @$args;
    my @in;
    foreach my $href (@$args) {
        push @in, "$href->{type} *$href->{name}"
            unless $href->{type} eq 'dummy';
    }
    return wantarray ? (\@in, \@pass) : \@in;
}

sub canon_proto {
    my ($prototype, $name) = @_;
    my ($in,$pass) = canon_args($prototype);

    local $" = ', ';

    my $p = "$prototype->{ret} $name(@$in)";
    $p =~ s/\* /*/;
    return wantarray ? ($p, "@$pass") : $p;
}

my %sources = (
   generate_handler_index      => {h => 'modperl_hooks.h'},
   generate_handler_hooks      => {h => 'modperl_hooks.h',
                                   c => 'modperl_hooks.c'},
   generate_handler_directives => {h => 'modperl_directives.h',
                                   c => 'modperl_directives.c'},
   generate_handler_find       => {h => 'modperl_hooks.h',
                                   c => 'modperl_hooks.c'},
   generate_flags              => {h => 'modperl_flags.h',
                                   c => 'modperl_flags.c'},
   generate_trace              => {h => 'modperl_trace.h'},
   generate_largefiles         => {h => 'modperl_largefiles.h'},
   generate_constants          => {h => 'modperl_constants.h',
                                   c => 'modperl_constants.c'},
   generate_exports            => {c => 'modperl_exports.c'},
);

my @c_src_names = qw(interp tipool log config cmd options callback handler
                     gtop util io io_apache filter bucket mgv pcw global env
                     cgi perl perl_global perl_pp sys module svptr_table
                     const constants apache_compat error debug
                     common_util common_log);
my @h_src_names = qw(perl_unembed);
my @g_c_names = map { "modperl_$_" } qw(hooks directives flags xsinit exports);
my @c_names   = ('mod_perl', (map "modperl_$_", @c_src_names));
sub c_files { [map { "$_.c" } @c_names, @g_c_names] }
sub o_files { [map { "$_.o" } @c_names, @g_c_names] }
sub o_pic_files { [map { "$_.lo" } @c_names, @g_c_names] }

my @g_h_names = map { "modperl_$_" } qw(hooks directives flags trace
                                        largefiles);
my @h_names = (@c_names, map { "modperl_$_" } @h_src_names,
               qw(types time apache_includes perl_includes apr_includes
                  apr_compat common_includes common_types));
sub h_files { [map { "$_.h" } @h_names, @g_h_names] }

sub clean_files {
    my @c_names = @g_c_names;
    my @h_names = @g_h_names;

    for (\@c_names, \@h_names) {
        push @$_, 'modperl_constants';
    }

    [(map { "$_.c" } @c_names), (map { "$_.h" } @h_names)];
}

sub classname {
    my $self = shift || __PACKAGE__;
    ref($self) || $self;
}

sub noedit_warning_c {
    my $class = classname(shift);

    my $v = join '/', $class, $class->VERSION;
    my $trace = Apache::TestConfig::calls_trace();
    $trace =~ s/^/ * /mg;
    return <<EOF;

/*
 * *********** WARNING **************
 * This file generated by $v
 * Any changes made here will be lost
 * ***********************************
$trace */

EOF
}

#this is named hash after the `#' character
#rather than named perl, since #comments are used
#non-Perl files, e.g. Makefile, typemap, etc.
sub noedit_warning_hash {
    my $class = classname(shift);

    (my $warning = noedit_warning_c($class)) =~ s/^/\# /mg;
    return $warning;
}

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

    return unless $name;
    return if $self->{init_files}->{$name}++;

    my (@preamble);
    if ($name =~ /\.h$/) {
        (my $d = uc $name) =~ s/\./_/;
        push @preamble, "#ifndef $d\n#define $d\n";
        push @{ $self->{postamble}->{$name} }, "\n#endif /* $d */\n";
    }
    elsif ($name =~ /\.c/) {
        push @preamble, qq{\#include "mod_perl.h"\n\n};
    }

    my $file = "$self->{path}/$name";
    debug "generating...$file";
    unlink $file;
    open my $fh, '>>', $file or die "open $file: $!";
    print $fh @preamble, noedit_warning_c();

    $self->{fh}->{$name} = $fh;
}

sub fh {
    my ($self, $name) = @_;
    return unless $name;
    $self->{fh}->{$name};
}

sub postamble {
    my $self = shift;
    for my $name (keys %{ $self->{fh} }) {
        next unless my $av = $self->{postamble}->{$name};
        print { $self->fh($name) } @$av;
    }
}

sub generate {
    my ($self, $build) = @_;

    $self->{build} = $build;

    for my $s (values %sources) {
        for (qw(h c)) {
            $self->init_file($s->{$_});
        }
    }

    for my $method (reverse sort keys %sources) {
        my ($h_fh, $c_fh) = map {
            $self->fh($sources{$method}->{$_});
        } qw(h c);
        my ($h_add, $c_add) = $self->$method($h_fh, $c_fh);
        if ($h_add) {
            print $h_fh $h_add;
        }
        if ($c_add) {
            print $c_fh $c_add;
        }
        debug "$method...done";
    }

    $self->postamble;

    my $xsinit = "$self->{path}/modperl_xsinit.c";
    debug "generating...$xsinit";

    #create bootstrap method for static xs modules
    my $static_xs = [keys %{ $build->{XS} }];
    ExtUtils::Embed::xsinit($xsinit, 1, $static_xs);

    #$self->generate_constants_pod();
}

my $constant_prefixes = join '|', qw{APR? MODPERL_RC};

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

    require Apache2::ConstantsTable;

    print $c_fh qq{\#include "modperl_const.h"\n};
    print $h_fh "#define MP_ENOCONST -3\n\n";

    generate_constants_lookup($h_fh, $c_fh);
    generate_constants_group_lookup($h_fh, $c_fh);
}

my %shortcuts = (
     NOT_FOUND => 'HTTP_NOT_FOUND',
     FORBIDDEN => 'HTTP_FORBIDDEN',
     AUTH_REQUIRED => 'HTTP_UNAUTHORIZED',
     SERVER_ERROR => 'HTTP_INTERNAL_SERVER_ERROR',
     REDIRECT => 'HTTP_MOVED_TEMPORARILY',
);

#backwards compat with older httpd/apr
#XXX: remove once we require newer httpd/apr
my %ifdef = map { $_, 1 } 
    qw(APLOG_TOCLIENT APR_LIMIT_NOFILE), # added in ???
    qw(AP_MPMQ_STARTING AP_MPMQ_RUNNING AP_MPMQ_STOPPING 
       AP_MPMQ_MPM_STATE), # added in 2.0.49
    qw(APR_FPROT_USETID APR_FPROT_GSETID
       APR_FPROT_WSTICKY APR_FOPEN_LARGEFILE); # added in 2.0.50?

sub constants_ifdef {
    my $name = shift;

    if ($ifdef{$name}) {
        return ("#ifdef $name\n", "#endif /* $name */\n");
    }

    ("", "");
}

sub constants_lookup_code {
    my ($h_fh, $c_fh, $constants, $class) = @_;

    my (%switch, %alias);

    %alias = %shortcuts;

    my $postfix = canon_lc(lc $class);
    my $package = $class . '::';
    my $package_len = length $package;
    my ($first_let) = $class =~ /^(\w)/;

    my $func = canon_func(qw(constants lookup), $postfix);
    my $proto = "SV \*$func(pTHX_ const char *name)";

    print $h_fh "$proto;\n";

    print $c_fh <<EOF;

$proto
{
    if (*name == '$first_let' && strnEQ(name, "$package", $package_len)) {
        name += $package_len;
    }

    switch (*name) {
EOF

    for (@$constants) {
        if (s/^($constant_prefixes)(_)?//o) {
            $alias{$_} = join $2 || "", $1, $_;
        }
        else {
            $alias{$_} ||= $_;
        }
        next unless /^([A-Z])/;
        push @{ $switch{$1} }, $_;
    }

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

        for my $name (@$names) {
            my @ifdef = constants_ifdef($alias{$name});
            print $c_fh <<EOF;
$ifdef[0]
          if (strEQ(name, "$name")) {
EOF

            if ($name eq 'DECLINE_CMD' || 
                $name eq 'DIR_MAGIC_TYPE' ||
                $name eq 'CRLF') {
                print $c_fh <<EOF;
              return newSVpv($alias{$name}, 0);
EOF
            }
            else {
                print $c_fh <<EOF;
              return newSViv($alias{$name});
EOF
            }

            print $c_fh <<EOF;
          }
$ifdef[1]
EOF
        }
        print $c_fh "      break;\n";
    }

    print $c_fh <<EOF
    };
    Perl_croak(aTHX_ "unknown $class\:: constant %s", name);
    return newSViv(MP_ENOCONST);
}
EOF
}

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

    while (my ($class, $groups) = each %$Apache2::ConstantsTable) {
        my $constants = [map { @$_ } values %$groups];

        constants_lookup_code($h_fh, $c_fh, $constants, $class);
    }
}

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

    while (my ($class, $groups) = each %$Apache2::ConstantsTable) {
        constants_group_lookup_code($h_fh, $c_fh, $class, $groups);
    }
}

sub constants_group_lookup_code {
    my ($h_fh, $c_fh, $class, $groups) = @_;
    my @tags;
    my @code;

    $class = canon_lc(lc $class);
    while (my ($group, $constants) = each %$groups) {
	push @tags, $group;
        my $name = join '_', 'MP_constants', $class, $group;
	print $c_fh "\nstatic const char *$name [] = { \n",
          (map {
              my @ifdef = constants_ifdef($_);
              s/^($constant_prefixes)_?//o;
              qq($ifdef[0]   "$_",\n$ifdef[1])
          } @$constants), "   NULL,\n};\n";
    }

    my %switch;
    for (@tags) {
        next unless /^([A-Z])/i;
        push @{ $switch{$1} }, $_;
    }

    my $func = canon_func(qw(constants group lookup), $class);

    my $proto = "const char **$func(const char *name)";

    print $h_fh "$proto;\n";
    print $c_fh "\n$proto\n{\n", "   switch (*name) {\n";

    for my $key (sort keys %switch) {
	my $val = $switch{$key};
	print $c_fh "\tcase '$key':\n";
	for my $group (@$val) {
            my $name = join '_', 'MP_constants', $class, $group;
	    print $c_fh qq|\tif(strEQ("$group", name))\n\t   return $name;\n|;
	}
        print $c_fh "      break;\n";
    }

    print $c_fh <<EOF;
    };
    Perl_croak_nocontext("unknown $class\:: group `%s'", name);
    return NULL;
}
EOF
}

my %seen_const = ();
# generates APR::Const and Apache2::Const manpages in ./tmp/
sub generate_constants_pod {
    my ($self) = @_;

    my %data = ();
    generate_constants_group_lookup_doc(\%data);
    generate_constants_lookup_doc(\%data);

    # XXX: may be dump %data into ModPerl::MethodLookup and provide an
    # easy api to map const groups to constants and vice versa

    require File::Path;
    my $file = "Const.pod";
    for my $class (keys %data) {
        my $path = catdir "tmp", $class;
        File::Path::mkpath($path, 0, 0755);
        my $filepath = catfile $path, $file;
        open my $fh, ">$filepath" or die "Can't open $filepath: $!\n";

        print $fh <<"EOF";
=head1 NAME

$class\::Const - Perl Interface for $class Constants

=head1 SYNOPSIS

=head1 CONSTANTS

EOF

        my $groups = $data{$class};
        for my $group (sort keys %$groups) {
            print $fh <<"EOF";



=head2 C<:$group>

  use $class\::Const -compile qw(:$group);

The C<:$group> group is for XXX constants.

EOF

            for my $const (sort @{ $groups->{$group} }) {
                print $fh "=head3 C<$class\::$const>\n\n\n";
            }
        }

        print $fh "=cut\n";
    }
}

sub generate_constants_lookup_doc {
    my ($data) = @_;

    while (my ($class, $groups) = each %$Apache2::ConstantsTable) {
        my $constants = [map { @$_ } values %$groups];

        constants_lookup_code_doc($constants, $class, $data);
    }
}

sub generate_constants_group_lookup_doc {
    my ($data) = @_;

    while (my ($class, $groups) = each %$Apache2::ConstantsTable) {
        constants_group_lookup_code_doc($class, $groups, $data);
    }
}

sub constants_group_lookup_code_doc {
    my ($class, $groups, $data) = @_;
    my @tags;
    my @code;

    while (my ($group, $constants) = each %$groups) {
        $data->{$class}{$group} = [
            map {
                my @ifdef = constants_ifdef($_);
                s/^($constant_prefixes)_?//o;
                $seen_const{$class}{$_}++;
                $_;
            } @$constants
        ];
    }
}

sub constants_lookup_code_doc {
    my ($constants, $class, $data) = @_;

    my (%switch, %alias);

    %alias = %shortcuts;

    my $postfix = lc $class;
    my $package = $class . '::';
    my $package_len = length $package;

    my $func = canon_func(qw(constants lookup), $postfix);

    for (@$constants) {
        if (s/^($constant_prefixes)(_)?//o) {
            $alias{$_} = join $2 || "", $1, $_;
        }
        else {
            $alias{$_} ||= $_;
        }
        next unless /^([A-Z])/;
        push @{ $switch{$1} }, $_;
    }

    for my $key (sort keys %switch) {
        my $names = $switch{$key};
        for my $name (@$names) {
            my @ifdef = constants_ifdef($alias{$name});
            push @{ $data->{$class}{other} }, $name
                unless $seen_const{$class}{$name}
        }
    }
}

sub generate_exports {
    my ($self, $c_fh) = @_;
    require ModPerl::WrapXS;
    ModPerl::WrapXS->generate_exports($c_fh);
}

# src/modules/perl/*.c files needed to build APR/APR::* outside
# of mod_perl.so
sub src_apr_ext {
    return map { "modperl_$_" } (qw(error bucket),
                                  map { "common_$_" } qw(util log));
}

1;
__END__

=head1 NAME

ModPerl::Code - Generate mod_perl glue code

=head1 SYNOPSIS

  use ModPerl::Code ();
  my $code = ModPerl::Code->new;
  $code->generate;

=head1 DESCRIPTION

This module provides functionality for generating mod_perl glue code.
Reason this code is generated rather than written by hand include:

=over 4

=item consistency

=item thin and clean glue code

=item enable/disable features (without #ifdefs)

=item adapt to changes in Apache

=item experiment with different approaches to gluing

=back

=head1 AUTHOR

Doug MacEachern

=cut